MacHome 2001 January/MacHome Magazine Demo Disc January 2001.iso/pc/Software/Applications/Squeak app design envir. ….sea/Squeak app design envir. 2.8/SqueakV2.sources

Text File | 1998-05-29 | 5.3 MB | 164,029 lines | [STch/FAST]

'From Squeak 2.0 of May 22, 1998 on 22 May 1998 at 4:32:15 pm'!
Object subclass: #AbstractScoreEvent
    instanceVariableNames: 'time '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Music-Scores'!
!AbstractScoreEvent commentStamp: 'di 5/22/1998 16:32' prior: 0!
Abstract class for timed events in a MIDI score.
!


!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'!
isNoteEvent

    ^ false
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:46'!
isTempoEvent

    ^ false
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'!
time

    ^ time
! !

!AbstractScoreEvent methodsFor: 'all' stamp: 'jm 12/31/97 11:43'!
time: aNumber

    time _ aNumber.
! !
Object subclass: #AbstractSound
    instanceVariableNames: 'envelopes mSecsSinceStart samplesUntilNextControl scaledVol scaledVolIncr scaledVolLimit '
    classVariableNames: 'MaxScaledValue ScaleFactor Sounds '
    poolDictionaries: ''
    category: 'System-Sound'!

!AbstractSound methodsFor: 'initialization' stamp: 'jm 12/9/97 11:31'!
duration: seconds
    "Scale my envelopes to the given duration. Subclasses overriding this method should include a resend to super."

    envelopes do: [:e | e duration: seconds].
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 2/4/98 09:54'!
initialize

    envelopes _ #().
    mSecsSinceStart _ 0.
    samplesUntilNextControl _ 0.
    scaledVol _ (1.0 * ScaleFactor) rounded.
    scaledVolIncr _ 0.
    scaledVolLimit _ scaledVol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 16:09'!
setLoudness: vol
    "Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super."

    envelopes do: [:e |
        (e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]].
    self initialVolume: vol.
! !

!AbstractSound methodsFor: 'initialization' stamp: 'jm 1/31/98 15:26'!
setPitch: p dur: d loudness: l
    "Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super."

    envelopes do: [:e |
        (e isKindOf: VolumeEnvelope) ifTrue: [e scale: l].
        (e isKindOf: PitchEnvelope) ifTrue: [e centerPitch: p].
        e duration: d].
    self initialVolume: l.
    self duration: d.

! !


!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/17/97 22:23'!
addEnvelope: anEnvelope
    "Add the given envelope to my envelopes list."

    anEnvelope target: self.
    envelopes _ envelopes copyWith: anEnvelope.
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
envelopes
    "Return my collection of envelopes."

    ^ envelopes
! !

!AbstractSound methodsFor: 'envelopes' stamp: 'jm 12/15/97 17:02'!
removeEnvelope: anEnvelope
    "Remove the given envelope from my envelopes list."

    envelopes _ envelopes copyWithout: anEnvelope.
! !


!AbstractSound methodsFor: 'volume' stamp: 'jm 2/4/98 06:49'!
adjustVolumeTo: vol overMSecs: mSecs
    "Adjust the volume of this sound to the given volume, a number in the range [0.0..1.0], over the given number of milliseconds. The volume will be changed a little bit on each sample until the desired volume is reached."

    | newScaledVol |
    newScaledVol _ (32768.0 * vol) truncated.
    newScaledVol = scaledVol ifTrue: [^ self].
    scaledVolLimit _ newScaledVol.
    scaledVolLimit > ScaleFactor ifTrue: [scaledVolLimit _ ScaleFactor].
    scaledVolLimit < 0 ifTrue: [scaledVolLimit _ 0].
    mSecs = 0
        ifTrue: [  "change immediately"
            scaledVol _ scaledVolLimit.
            scaledVolIncr _ 0]
        ifFalse: [
            scaledVolIncr _
                ((scaledVolLimit - scaledVol) * 1000) // (self samplingRate * mSecs)].
! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 12/17/97 17:39'!
initialVolume: vol
    "Set the initial volume of this sound to the given volume, a number in the range [0.0..1.0]."

    scaledVol _ (((vol asFloat min: 1.0) max: 0.0) * ScaleFactor) rounded.
    scaledVolLimit _ scaledVol.
    scaledVolIncr _ 0.
! !

!AbstractSound methodsFor: 'volume' stamp: 'di 1/31/98 15:55'!
loudness
    "Return a suitable volume for initing"

    ^ scaledVol asFloat / ScaleFactor asFloat! !

!AbstractSound methodsFor: 'volume' stamp: 'jm 12/16/97 10:30'!
volumeEnvelopeScaledTo: scalePoint
    "Return a collection of values representing my volume envelope scaled by the given point. The scale point's x component is pixels/second and its y component is the number of pixels for full volume."

    | env amp vScale cnt oldT newT totalCnt |
    self error: 'not yet implemented'.

"old code:"
    totalCnt _ "initialCount" 1000.
    env _ Array new: (totalCnt * scalePoint x // self samplingRate min: 500).
    amp _ scaledVol asFloat / ScaleFactor.
    vScale _ scalePoint y asFloat / 1000.0.
    cnt _ totalCnt.
    oldT _ newT _ 0.  "Time in units of scale x per second"
    [cnt > 0 and: [newT <= env size]] whileTrue:
        [env atAll: (oldT+1 to: newT) put: (amp*vScale) asInteger.
        oldT _ newT.
        "amp _ amp * decayRate."
        cnt _ cnt - samplesUntilNextControl.
        newT _ totalCnt - cnt * scalePoint x // self samplingRate].
    env atAll: ((oldT+1 min: env size) to: env size) put: (amp*vScale) asInteger.
    ^ env
! !


!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
computeSamplesForSeconds: seconds
    "Compute the samples of this sound without outputting them, and return the resulting buffer of samples."

    | buf |
    self reset.
    buf _ SoundBuffer newStereoSampleCount: (self samplingRate * seconds) asInteger.
    self playSampleCount: buf stereoSampleCount into: buf startingAt: 1.
    ^ buf
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 8/24/97 20:48'!
pause
    "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning."

    SoundPlayer pauseSound: self.! !

!AbstractSound methodsFor: 'playing'!
play
    "Play this sound to the sound ouput port in real time."

    SoundPlayer playSound: self.! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 12/9/97 10:46'!
playAndWaitUntilDone
    "Play this sound to the sound ouput port in real time."

    SoundPlayer playSound: self.
    [self samplesRemaining > 0] whileTrue.
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
playSampleCount: n into: aSoundBuffer startingAt: startIndex
    "Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."

    | fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count |
    fullVol _ AbstractSound scaleFactor.
    samplesBetweenControlUpdates _ self samplingRate // self controlRate.
    pastEnd _ startIndex + n.  "index just index of after last sample"
    i _ startIndex.
    [i < pastEnd] whileTrue: [
        remainingSamples _ self samplesRemaining.
        remainingSamples <= 0 ifTrue: [^ self].
        count _ pastEnd - i.
        samplesUntilNextControl < count ifTrue: [count _ samplesUntilNextControl].
        remainingSamples < count ifTrue: [count _ remainingSamples].
        self mixSampleCount: count into: aSoundBuffer startingAt: i leftVol: fullVol rightVol: fullVol.
        samplesUntilNextControl _ samplesUntilNextControl - count.
        samplesUntilNextControl <= 0 ifTrue: [
            self doControl.
            samplesUntilNextControl _ samplesBetweenControlUpdates].
        i _ i + count].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:05'!
playSilently
    "Compute the samples of this sound without outputting them. Used for performance analysis."

    | buf |
    self reset.
    buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).
    [self samplesRemaining > 0] whileTrue: [
        buf primFill: 0.
        self playSampleCount: buf stereoSampleCount into: buf startingAt: 1].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 1/26/98 22:06'!
playSilentlyUntil: startTime
    "Compute the samples of this sound without outputting them. Used to fast foward to a particular starting time. The start time is given in seconds."

    | buf startSample nextSample samplesRemaining n |
    self reset.
    buf _ SoundBuffer newStereoSampleCount: (self samplingRate // 10).
    startSample _ (startTime * self samplingRate) asInteger.
    nextSample _ 1.
    [self samplesRemaining > 0] whileTrue: [
        nextSample >= startSample ifTrue: [^ self].
        samplesRemaining _ startSample - nextSample.
        samplesRemaining > buf stereoSampleCount
            ifTrue: [n _ buf stereoSampleCount]
            ifFalse: [n _ samplesRemaining].
        self playSampleCount: n into: buf startingAt: 1.
        nextSample _ nextSample + n].
! !

!AbstractSound methodsFor: 'playing' stamp: 'jm 3/4/98 13:16'!
resumePlaying
    "Resume playing this sound from where it last stopped."

    SoundPlayer resumePlaying: self.
! !


!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 09:56'!
doControl
    "Update the control parameters of this sound using its envelopes, if any."
    "Note: This is only called at a small fraction of the sampling rate."

    | pitchModOrRatioChange |
    mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate).
    envelopes size > 0 ifTrue: [
        pitchModOrRatioChange _ false.
        1 to: envelopes size do: [:i |
            ((envelopes at: i) updateTargetAt: mSecsSinceStart)
                ifTrue: [pitchModOrRatioChange _ true]].
        pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 08:56'!
internalizeModulationAndRatio
    "Overridden by FMSound. This default implementation does nothing."
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 11/24/97 16:00'!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
    "Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The leftVol and rightVol parameters determine the volume of the sound in each channel, where 0 is silence and 1000 is full volume."

    self subclassResponsibility.
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 2/4/98 18:59'!
reset
    "Reset my internal state for a replay. Methods that override this method should do super reset."

    mSecsSinceStart _ 0.
    samplesUntilNextControl _ self samplingRate // self controlRate.
    envelopes size > 0 ifTrue: [
        1 to: envelopes size do: [:i | (envelopes at: i) reset]].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
samplesRemaining
    "Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."

    ^ 1000000
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 1/5/98 14:21'!
storeSample: sample in: aSoundBuffer at: sliceIndex leftVol: leftVol rightVol: rightVol
    "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, this method is hand-inlined into all sound generation methods that use it."

    | i s |
        leftVol > 0 ifTrue: [
            i _ (2 * sliceIndex) - 1.
            s _ (aSoundBuffer at: i) + ((sample * leftVol) // ScaleFactor).
            s >  32767 ifTrue: [s _  32767].  "clipping!!"
            s < -32767 ifTrue: [s _ -32767].  "clipping!!"
            aSoundBuffer at: i put: s].
        rightVol > 0 ifTrue: [
            i _ 2 * sliceIndex.
            s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor).
            s >  32767 ifTrue: [s _  32767].  "clipping!!"
            s < -32767 ifTrue: [s _ -32767].  "clipping!!"
            aSoundBuffer at: i put: s].
! !

!AbstractSound methodsFor: 'sound generation' stamp: 'jm 12/17/97 17:57'!
updateVolume
    "Increment the volume envelope of this sound. To avoid clicks, the volume envelope must be interpolated at the sampling rate, rather than just at the control rate like other envelopes. At the control rate, the volume envelope computes the slope and next target volume volume for the current segment of the envelope (i.e., it sets the rate of change for the volume parameter). When that target volume is reached, incrementing is stopped until a new increment is set."
    "This method is provided for documentation. To gain 10% more speed when running sound generation in Smalltalk, it is hand-inlined into all sound generation methods that use it."

        scaledVolIncr ~= 0 ifTrue: [
            scaledVol _ scaledVol + scaledVolIncr.
            ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or:
             [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]])
                ifTrue: [  "reached the limit; stop incrementing"
                    scaledVol _ scaledVolLimit.
                    scaledVolIncr _ 0]].
! !


!AbstractSound methodsFor: 'composition'!
+ aSound
    "Return the mix of the receiver and the argument sound."

    ^ MixedSound new
        add: self;
        add: aSound
! !

!AbstractSound methodsFor: 'composition'!
, aSound
    "Return the concatenation of the receiver and the argument sound."

    ^ SequentialSound new
        add: self;
        add: aSound
! !

!AbstractSound methodsFor: 'composition' stamp: 'jm 12/17/97 18:00'!
delayedBy: seconds
    "Return a composite sound consisting of a rest for the given amount of time followed by the receiver."

    ^ (RestSound dur: seconds), self
! !


!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/15/97 14:15'!
controlRate
    "Answer the number of control changes per second."

    ^ 100
! !

!AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/17/97 18:00'!
samplingRate
    "Answer the sampling rate in samples per second."

    ^ SoundPlayer samplingRate
! !


!AbstractSound methodsFor: 'copying' stamp: 'jm 12/15/97 19:15'!
copy
    "A sound should copy all of the state needed to play itself, allowing two copies of a sound to play at the same time. These semantics require a recursive copy but only down to the level of immutable data. For example, a SampledSound need not copy its sample buffer. Subclasses overriding this method should include a resend to super."

    ^ self clone copyEnvelopes
! !

!AbstractSound methodsFor: 'copying' stamp: 'jm 12/17/97 22:22'!
copyEnvelopes
    "Private!! Support for copying. Copy my envelopes."

    envelopes _ envelopes collect: [:e | e copy target: self].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractSound class
    instanceVariableNames: ''!

!AbstractSound class methodsFor: 'class initialization' stamp: 'di 2/2/98 14:39'!
initialize
    "AbstractSound initialize"

    ScaleFactor _ 2 raisedTo: 15.
    MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1.  "magnitude of largest scaled value in 32-bits"! !

!AbstractSound class methodsFor: 'class initialization' stamp: 'jm 1/5/98 13:51'!
scaleFactor

    ^ ScaleFactor
! !


!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 1/5/98 17:40'!
default
    "Return a default sound prototype for this class, with envelopes if appropriate. (This is in contrast to new, which returns a raw instance without envelopes.)"

    ^ self new
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'!
dur: d
    "Return a rest of the given duration."

    ^ self basicNew setDur: d
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:26'!
new

    ^ self basicNew initialize
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'di 1/30/98 14:28'!
noteSequenceOn: aSound from: anArray
    "Build a note sequence (i.e., a SequentialSound) from the given array using the given sound as the instrument. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs.  Pitches can be given as names or as numbers."
    | score pitch |
    score _ SequentialSound new.
    anArray do: [:el |
        el size = 3
            ifTrue: [
                pitch _ el at: 1.
                pitch isNumber ifFalse: [pitch _ self pitchForName: pitch].
                score add: (
                    aSound copy
                        setPitch: pitch
                        dur: (el at: 2)
                        loudness: (el at: 3) / 1000.0)]
            ifFalse: [
                score add: (RestSound dur: (el at: 2))]].
    ^ score
! !

!AbstractSound class methodsFor: 'instance creation' stamp: 'jm 12/17/97 17:27'!
pitch: p dur: d loudness: l
    "Return a new sound object for a note with the given parameters."

    ^ self new setPitch: p dur: d loudness: l
! !

!AbstractSound class methodsFor: 'instance creation'!
pitchForName: aString
    "AbstractSound pitchForName: 'c2'"
    "#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']"

    | s modifier octave i j noteName p |
    s _ ReadStream on: aString.
    modifier _ $n.
    noteName _ s next.
    (s atEnd not and: [s peek isDigit]) ifFalse: [ modifier _ s next ].
    s atEnd
        ifTrue: [ octave _ 4 ]
        ifFalse: [ octave _ Integer readFrom: s ].
    octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ].
    i _ 'cdefgab' indexOf: noteName.
    i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ].
    i _ #(2 4 6 7 9 11 13) at: i.
    j _ 's#fb' indexOf: modifier.
    j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ].  "i is now in range: [1..14]"
    "Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]"
    p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i.
    octave timesRepeat: [ p _ 2.0 * p ].
    ^ p
! !


!AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:33'!
chromaticPitchesFrom: aPitch
    | pitch halfStep |
    pitch _ aPitch isNumber
            ifTrue: [aPitch]
            ifFalse: [self pitchForName: aPitch].
    halfStep _ self halfStep.
    pitch _ pitch / halfStep.
    ^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep]! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:35'!
chromaticScale
    "PluckedSound chromaticScale play"

    ^ self chromaticScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'!
chromaticScaleOn: aSound
    "PluckedSound chromaticScale play"

    ^ self noteSequenceOn: aSound
        from: (((self chromaticPitchesFrom: #c4) copyFrom: 1 to: 13)
             collect: [:pitch | Array with: pitch with: 0.5 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/31/98 00:32'!
halfStep
    ^ 2.0 raisedTo: 1.0/12.0! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
hiMajorScale
    "FMSound hiMajorScale play"

    ^ self hiMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
hiMajorScaleOn: aSound
    "FMSound hiMajorScale play"

    ^ self majorScaleOn: aSound from: #c6! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:36'!
lowMajorScale
    "PluckedSound lowMajorScale play"

    ^ self lowMajorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:01'!
lowMajorScaleOn: aSound
    "PluckedSound lowMajorScale play"

    ^ self majorScaleOn: aSound from: #c3! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:04'!
majorChord
    "FMSound majorChord play"
    ^ self majorChordOn: self default from: #c4! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:25'!
majorChordOn: aSound from: aPitch
    "FMSound majorChord play"
    | score majorScale leadingRest pan note |
    majorScale _ self majorPitchesFrom: aPitch.
    score _ MixedSound new.
    leadingRest _ pan _ 0.
    #(1 3 5 8) do: [:noteIndex |
        note _ aSound copy
            setPitch: (majorScale at: noteIndex)
            dur: 2.0 - leadingRest
            loudness: 0.3.
        score add: (RestSound dur: leadingRest), note pan: pan.
        leadingRest _ leadingRest + 0.2.
        pan _ pan + 0.3].
    ^ score
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 14:45'!
majorPitchesFrom: aPitch
    | chromatic |
    chromatic _ self chromaticPitchesFrom: aPitch.
    ^ #(1 3 5 6 8 10 12 13 15 13 12 10 8 6 5 3 1) collect: [:i | chromatic at: i].
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:34'!
majorScale
    "FMSound majorScale play"

    ^ self majorScaleOn: self default
! !

!AbstractSound class methodsFor: 'examples' stamp: 'di 1/30/98 16:00'!
majorScaleOn: aSound
    "FMSound majorScale play"

    ^ self majorScaleOn: aSound from: #c5! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/31/98 16:14'!
majorScaleOn: aSound from: aPitch
    "FMSound majorScale play"

    ^ self noteSequenceOn: aSound
        from: ((self majorPitchesFrom: aPitch)
             collect: [:pitch | Array with: pitch with: 0.25 with: 300])
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 1/5/98 17:32'!
scaleTest
    "AbstractSound scaleTest play"

    ^ MixedSound new
        add: FMSound majorScale pan: 0;
        add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1.0.
! !

!AbstractSound class methodsFor: 'examples' stamp: 'jm 12/17/97 21:25'!
testFMInteractively
    "Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
    "AbstractSound testFMInteractively"

    | s mousePt lastVal status mod mult |
    SoundPlayer startPlayerProcessBufferSize: 1100 rate: 11025 stereo: false.
    s _ FMSound pitch: 440.0 dur: 200.0 loudness: 0.2.

    SoundPlayer playSound: s.
    lastVal _ nil.
    [Sensor anyButtonPressed] whileFalse: [
        mousePt _ Sensor cursorPoint.
        mousePt ~= lastVal ifTrue: [
            mod _ mousePt x asFloat / 20.0.
            mult _ mousePt y asFloat / 20.0.
            s modulation: mod multiplier: mult.
            lastVal _ mousePt.
            status _
'mod: ', mod printString, '
mult: ', mult printString.
            status asParagraph displayOn: Display at: 10@10]].

    SoundPlayer shutDown.
! !


!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:38'!
bachFugue
    "Play a fugue by J. S. Bach using and instance of me as the sound for all four voices."
    "PluckedSound bachFugue play"

    ^ self bachFugueOn: self default
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 18:27'!
bachFugueOn: aSound
    "Play a fugue by J. S. Bach using the given sound as the sound for all four voices."
    "PluckedSound bachFugue play"

    ^ MixedSound new
        add: (self bachFugueVoice1On: aSound) pan: 1.0;
        add: (self bachFugueVoice2On: aSound) pan: 0.0;
        add: (self bachFugueVoice3On: aSound) pan: 1.0;
        add: (self bachFugueVoice4On: aSound) pan: 0.0.
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:51'!
bachFugueVoice1On: aSound
    "Voice one of a fugue by J. S. Bach."

    ^ self noteSequenceOn: aSound from: #(
        (1047 0.15 268)
        (988  0.15 268)
        (1047 0.30 268)
        (784  0.30 268)
        (831  0.30 268)
        (1047 0.15 268)
        (988  0.15 268)
        (1047 0.30 268)
        (1175 0.30 268)
        (784  0.30 268)
        (1047 0.15 268)
        (988  0.15 268)
        (1047 0.30 268)
        (1175 0.30 268)
        (698  0.15 268)
        (784  0.15 268)
        (831  0.60 268)
        (784  0.15 268)
        (698  0.15 268)
        (622  0.15 268)
        (1047 0.15 268)
        (988  0.15 268)
        (880  0.15 268)
        (784  0.15 268)
        (698  0.15 268)
        (622  0.15 268)
        (587  0.15 268)
        (523  0.30 268)
        (1245 0.30 268)
        (1175 0.30 268)
        (1047 0.30 268)
        (932  0.30 268)
        (880  0.30 268)
        (932  0.30 268)
        (1047 0.30 268)
        (740  0.30 268)
        (784  0.30 268)
        (880  0.30 268)
        (740  0.30 268)
        (784  0.60 268)
        (rest 0.15)
        (523  0.15 268)
        (587  0.15 268)
        (622  0.15 268)
        (698  0.15 268)
        (784  0.15 268)
        (831  0.45 268)
        (587  0.15 268)
        (622  0.15 268)
        (698  0.15 268)
        (784  0.15 268)
        (880  0.15 268)
        (932  0.45 268)
        (622  0.15 268)
        (698  0.15 268)
        (784  0.15 268)
        (831  0.15 268)
        (784  0.15 268)
        (698  0.15 268)
        (622  0.15 268)
        (587  0.30 268)
        (1047 0.15 268)
        (988  0.15 268)
        (1047 0.60 268)
        (rest 0.9)
        (1397 0.30 268)
        (1245 0.30 268)
        (1175 0.30 268)
        (rest 0.3)
        (831  0.30 268)
        (784  0.30 268)
        (698  0.30 268)
        (784  0.30 268)
        (698  0.15 268)
        (622  0.15 268)
        (698  0.30 268)
        (587  0.30 268)
        (784  0.60 268)
        (rest 0.3)
        (988  0.30 268)
        (1047 0.30 268)
        (1047 0.15 268)
        (988  0.15 268)
        (1047 0.30 268)
        (784  0.30 268)
        (831  0.60 268)
        (rest 0.3)
        (880  0.30 268)
        (932  0.30 268)
        (932  0.15 268)
        (880  0.15 268)
        (932  0.30 268)
        (698  0.30 268)
        (784  0.60 268)
        (rest 0.3)
        (784  0.30 268)
        (831  0.30 268)
        (831  0.30 268)
        (784  0.30 268)
        (698  0.30 268)
        (rest 0.3)
        (415  0.30 268)
        (466  0.30 268)
        (523  0.30 268)
        (rest 0.3)
        (415  0.15 268)
        (392  0.15 268)
        (415  0.30 268)
        (349  0.30 268)
        (466  0.30 268)
        (523  0.30 268)
        (466  0.30 268)
        (415  0.30 268)
        (466  0.30 268)
        (392  0.30 268)
        (349  0.30 268)
        (311  0.30 268)
        (349  0.30 268)
        (554  0.30 268)
        (523  0.30 268)
        (466  0.30 268)
        (523  0.30 268)
        (415  0.30 268)
        (392  0.30 268)
        (349  0.30 268)
        (392  0.30 268)
        (784  0.15 268)
        (740  0.15 268)
        (784  0.30 268)
        (523  0.30 268)
        (622  0.30 268)
        (784  0.15 268)
        (740  0.15 268)
        (784  0.30 268)
        (880  0.30 268)
        (587  0.30 268)
        (784  0.15 268)
        (740  0.15 268)
        (784  0.30 268)
        (880  0.30 268)
        (523  0.15 268)
        (587  0.15 268)
        (622  0.60 268)
        (587  0.15 268)
        (523  0.15 268)
        (466  0.30 346)
        (rest 0.45)
        (587  0.15 346)
        (659  0.15 346)
        (740  0.15 346)
        (784  0.15 346)
        (880  0.15 346)
        (932  0.45 346)
        (659  0.15 346)
        (698  0.15 346)
        (784  0.15 346)
        (880  0.15 346)
        (932  0.15 346)
        (1047 0.45 346)
        (740  0.15 346)
        (784  0.15 346)
        (880  0.15 346)
        (932  0.30 346)
        (622  0.15 346)
        (587  0.15 346)
        (622  0.30 346)
        (392  0.30 346)
        (415  0.30 346)
        (698  0.15 346)
        (622  0.15 346)
        (698  0.30 346)
        (440  0.30 346)
        (466  0.30 346)
        (784  0.15 346)
        (698  0.15 346)
        (784  0.30 346)
        (494  0.30 346)
        (523  0.15 346)
        (698  0.15 346)
        (622  0.15 346)
        (587  0.15 346)
        (523  0.15 346)
        (466  0.15 346)
        (440  0.15 346)
        (392  0.15 346)
        (349  0.30 346)
        (831  0.30 346)
        (784  0.30 346)
        (698  0.30 346)
        (622  0.30 346)
        (587  0.30 346)
        (622  0.30 346)
        (698  0.30 346)
        (494  0.30 346)
        (523  0.30 346)
        (587  0.30 346)
        (494  0.30 346)
        (523  0.60 346)
        (rest 0.3)
        (659  0.30 346)
        (698  0.30 346)
        (698  0.15 346)
        (659  0.15 346)
        (698  0.30 346)
        (523  0.30 346)
        (587  0.60 346)
        (rest 0.3)
        (587  0.30 346)
        (622  0.30 346)
        (622  0.15 346)
        (587  0.15 346)
        (622  0.30 346)
        (466  0.30 346)
        (523  1.20 346)
        (523  0.30 346)
        (587  0.15 346)
        (622  0.15 346)
        (698  0.15 346)
        (622  0.15 346)
        (698  0.15 346)
        (587  0.15 346)
        (494  0.30 457)
        (rest 0.6)
        (494  0.30 457)
        (523  0.30 457)
        (rest 0.6)
        (622  0.30 457)
        (587  0.30 457)
        (rest 0.6)
        (698  0.60 457)
        (rest 0.6)
        (698  0.30 457)
        (622  0.30 457)
        (831  0.30 457)
        (784  0.30 457)
        (698  0.30 457)
        (622  0.30 457)
        (587  0.30 457)
        (622  0.30 457)
        (698  0.30 457)
        (494  0.30 457)
        (523  0.30 457)
        (587  0.30 457)
        (494  0.30 457)
        (494  0.30 457)
        (523  0.30 457)
        (rest 0.3)
        (523  0.30 457)
        (698  0.15 457)
        (587  0.15 457)
        (622  0.15 457)
        (523  0.45 457)
        (494  0.30 457)
        (523  0.60 457)
        (rest 0.3)
        (659  0.30 268)
        (698  0.60 268)
        (rest 0.3)
        (698  0.30 268)
        (698  0.30 268)
        (622  0.15 268)
        (587  0.15 268)
        (622  0.30 268)
        (698  0.30 268)
        (587  0.40 268)
        (rest 0.4)
        (587  0.40 268)
        (rest 0.4)
        (523  1.60 268)).! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice2On: aSound
    "Voice two of a fugue by J. S. Bach."

    ^ self noteSequenceOn: aSound from: #(
        (rest 4.8)
        (1568 0.15 346)
        (1480 0.15 346)
        (1568 0.30 346)
        (1047 0.30 346)
        (1245 0.30 346)
        (1568 0.15 346)
        (1480 0.15 346)
        (1568 0.30 346)
        (1760 0.30 346)
        (1175 0.30 346)
        (1568 0.15 346)
        (1480 0.15 346)
        (1568 0.30 346)
        (1760 0.30 346)
        (1047 0.15 346)
        (1175 0.15 346)
        (1245 0.60 346)
        (1175 0.15 346)
        (1047 0.15 346)
        (932  0.30 346)
        (1245 0.15 346)
        (1175 0.15 346)
        (1245 0.30 346)
        (784  0.30 346)
        (831  0.30 346)
        (1397 0.15 346)
        (1245 0.15 346)
        (1397 0.30 346)
        (880  0.30 346)
        (932  0.30 346)
        (1568 0.15 346)
        (1397 0.15 346)
        (1568 0.30 346)
        (988  0.30 346)
        (1047 0.30 346)
        (1175 0.15 346)
        (1245 0.15 346)
        (1397 0.90 346)
        (1245 0.15 346)
        (1175 0.15 346)
        (1047 0.15 346)
        (932  0.15 346)
        (831  0.15 346)
        (784  0.15 346)
        (698  0.30 346)
        (1661 0.30 346)
        (1568 0.30 346)
        (1397 0.30 346)
        (1245 0.30 346)
        (1175 0.30 346)
        (1245 0.30 346)
        (1397 0.30 346)
        (988  0.30 346)
        (1047 0.30 346)
        (1175 0.30 346)
        (988  0.30 346)
        (1047 0.30 457)
        (1568 0.15 457)
        (1480 0.15 457)
        (1568 0.30 457)
        (1175 0.30 457)
        (1245 0.60 457)
        (rest 0.3)
        (1319 0.30 457)
        (1397 0.30 457)
        (1397 0.15 457)
        (1319 0.15 457)
        (1397 0.30 457)
        (1047 0.30 457)
        (1175 0.60 457)
        (rest 0.3)
        (1175 0.30 457)
        (1245 0.30 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1245 0.30 457)
        (932  0.30 457)
        (1047 0.30 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1245 0.30 457)
        (1397 0.30 457)
        (932  0.30 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1245 0.30 457)
        (1397 0.30 457)
        (831  0.15 457)
        (932  0.15 457)
        (1047 0.60 457)
        (932  0.15 457)
        (831  0.15 457)
        (784  0.15 457)
        (622  0.15 457)
        (698  0.15 457)
        (784  0.15 457)
        (831  0.15 457)
        (932  0.15 457)
        (1047 0.15 457)
        (1175 0.15 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1047 0.15 457)
        (1175 0.15 457)
        (1245 0.15 457)
        (1397 0.15 457)
        (1568 0.15 457)
        (1760 0.15 457)
        (1865 0.15 457)
        (698  0.15 457)
        (784  0.15 457)
        (831  0.15 457)
        (932  0.15 457)
        (1047 0.15 457)
        (1175 0.15 457)
        (1319 0.15 457)
        (1397 0.15 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1245 0.15 457)
        (1397 0.15 457)
        (1568 0.15 457)
        (1760 0.15 457)
        (1976 0.15 457)
        (2093 0.30 457)
        (1976 0.15 457)
        (1760 0.15 457)
        (1568 0.15 457)
        (1397 0.15 457)
        (1245 0.15 457)
        (1175 0.15 457)
        (1047 0.30 457)
        (1245 0.30 457)
        (1175 0.30 457)
        (1047 0.30 457)
        (932  0.30 457)
        (880  0.30 457)
        (932  0.30 457)
        (1047 0.30 457)
        (740  0.30 457)
        (784  0.30 457)
        (880  0.30 457)
        (740  0.30 457)
        (784  0.30 457)
        (1175 0.15 457)
        (1047 0.15 457)
        (1175 0.30 457)
        (rest 0.6)
        (1319 0.15 457)
        (1175 0.15 457)
        (1319 0.30 457)
        (rest 0.6)
        (1480 0.15 457)
        (1319 0.15 457)
        (1480 0.30 457)
        (rest 0.6)
        (784  0.15 457)
        (698  0.15 457)
        (784  0.30 457)
        (rest 0.6)
        (880  0.15 457)
        (784  0.15 457)
        (880  0.30 457)
        (rest 0.6)
        (988  0.15 457)
        (880  0.15 457)
        (988  0.30 457)
        (rest 0.6)
        (1047 0.15 457)
        (988  0.15 457)
        (1047 0.30 457)
        (784  0.30 457)
        (831  0.30 457)
        (1047 0.15 457)
        (988  0.15 457)
        (1047 0.30 457)
        (1175 0.30 457)
        (784  0.30 457)
        (1047 0.15 457)
        (988  0.15 457)
        (1047 0.30 457)
        (1175 0.30 457)
        (698  0.15 457)
        (784  0.15 457)
        (831  0.60 457)
        (784  0.15 457)
        (698  0.15 457)
        (622  0.30 457)
        (1047 0.15 457)
        (988  0.15 457)
        (1047 0.30 457)
        (784  0.30 457)
        (831  0.60 457)
        (rest 0.3)
        (880  0.30 457)
        (932  0.30 457)
        (932  0.15 457)
        (880  0.15 457)
        (932  0.30 457)
        (698  0.30 457)
        (784  0.60 457)
        (rest 0.3)
        (784  0.60 457)
        (831  0.15 457)
        (932  0.15 457)
        (1047 0.15 457)
        (988  0.15 457)
        (1047 0.15 457)
        (831  0.15 457)
        (698  1.20 457)
        (698  0.30 591)
        (1175 0.15 591)
        (1047 0.15 591)
        (1175 0.30 591)
        (698  0.30 591)
        (622  0.30 591)
        (1245 0.15 591)
        (1175 0.15 591)
        (1245 0.30 591)
        (784  0.30 591)
        (698  0.30 591)
        (1397 0.15 591)
        (1245 0.15 591)
        (1397 0.30 591)
        (831  0.30 591)
        (784  0.15 591)
        (1397 0.15 591)
        (1245 0.15 591)
        (1175 0.15 591)
        (1047 0.15 591)
        (988  0.15 591)
        (880  0.15 591)
        (784  0.15 591)
        (1047 0.30 591)
        (1397 0.30 591)
        (1245 0.30 591)
        (1175 0.30 591)
        (rest 0.3)
        (831  0.30 591)
        (784  0.30 591)
        (698  0.30 591)
        (784  0.30 591)
        (698  0.15 591)
        (622  0.15 591)
        (698  0.30 591)
        (587  0.30 591)
        (831  0.30 591)
        (784  0.30 591)
        (rest 0.3)
        (880  0.30 591)
        (988  0.30 591)
        (1047 0.30 591)
        (698  0.15 591)
        (622  0.15 591)
        (587  0.15 591)
        (523  0.15 591)
        (523  0.30 591)
        (1047 0.15 346)
        (988  0.15 346)
        (1047 0.30 346)
        (784  0.30 346)
        (831  0.30 346)
        (1047 0.15 346)
        (988  0.15 346)
        (1047 0.30 346)
        (1175 0.30 346)
        (784  0.30 346)
        (1047 0.15 346)
        (988  0.15 346)
        (1047 0.30 346)
        (1175 0.30 346)
        (698  0.20 346)
        (784  0.20 346)
        (831  0.80 346)
        (784  0.20 346)
        (698  0.20 346)
        (659  1.60 346)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice3On: aSound
    "Voice three of a fugue by J. S. Bach."

    ^ self noteSequenceOn: aSound from: #(
        (rest 14.4)
        (523  0.15 457)
        (494  0.15 457)
        (523  0.30 457)
        (392  0.30 457)
        (415  0.30 457)
        (523  0.15 457)
        (494  0.15 457)
        (523  0.30 457)
        (587  0.30 457)
        (392  0.30 457)
        (523  0.15 457)
        (494  0.15 457)
        (523  0.30 457)
        (587  0.30 457)
        (349  0.15 457)
        (392  0.15 457)
        (415  0.60 457)
        (392  0.15 457)
        (349  0.15 457)
        (311  0.15 457)
        (523  0.15 457)
        (494  0.15 457)
        (440  0.15 457)
        (392  0.15 457)
        (349  0.15 457)
        (311  0.15 457)
        (294  0.15 457)
        (262  0.15 457)
        (294  0.15 457)
        (311  0.15 457)
        (294  0.15 457)
        (262  0.15 457)
        (233  0.15 457)
        (208  0.15 457)
        (196  0.15 457)
        (175  0.15 457)
        (466  0.15 457)
        (415  0.15 457)
        (392  0.15 457)
        (349  0.15 457)
        (311  0.15 457)
        (294  0.15 457)
        (262  0.15 457)
        (233  0.15 457)
        (262  0.15 457)
        (294  0.15 457)
        (262  0.15 457)
        (233  0.15 457)
        (208  0.15 457)
        (196  0.15 457)
        (175  0.15 457)
        (156  0.15 457)
        (415  0.15 457)
        (392  0.15 457)
        (349  0.15 457)
        (311  0.15 457)
        (277  0.15 457)
        (262  0.15 457)
        (233  0.15 457)
        (208  0.30 457)
        (523  0.30 457)
        (466  0.30 457)
        (415  0.30 457)
        (392  0.30 457)
        (349  0.30 457)
        (392  0.30 457)
        (415  0.30 457)
        (294  0.30 457)
        (311  0.30 457)
        (349  0.30 457)
        (294  0.30 457)
        (311  0.30 457)
        (415  0.30 457)
        (392  0.30 457)
        (349  0.30 457)
        (392  0.30 457)
        (311  0.30 457)
        (294  0.30 457)
        (262  0.30 457)
        (294  0.30 457)
        (466  0.30 457)
        (415  0.30 457)
        (392  0.30 457)
        (415  0.30 457)
        (349  0.30 457)
        (311  0.30 457)
        (294  0.30 457)
        (311  0.30 457)
        (rest 1.2)
        (262  0.30 457)
        (233  0.30 457)
        (220  0.30 457)
        (rest 0.3)
        (311  0.30 457)
        (294  0.30 457)
        (262  0.30 457)
        (294  0.30 457)
        (262  0.15 457)
        (233  0.15 457)
        (262  0.30 457)
        (294  0.30 457)
        (196  0.30 591)
        (466  0.15 591)
        (440  0.15 591)
        (466  0.30 591)
        (294  0.30 591)
        (311  0.30 591)
        (523  0.15 591)
        (466  0.15 591)
        (523  0.30 591)
        (330  0.30 591)
        (349  0.30 591)
        (587  0.15 591)
        (523  0.15 591)
        (587  0.30 591)
        (370  0.30 591)
        (392  0.60 591)
        (rest 0.15)
        (196  0.15 591)
        (220  0.15 591)
        (247  0.15 591)
        (262  0.15 591)
        (294  0.15 591)
        (311  0.45 591)
        (220  0.15 591)
        (233  0.15 591)
        (262  0.15 591)
        (294  0.15 591)
        (311  0.15 591)
        (349  0.45 591)
        (247  0.15 591)
        (262  0.15 591)
        (294  0.15 591)
        (311  0.30 591)
        (rest 0.6)
        (330  0.30 591)
        (349  0.30 591)
        (175  0.30 591)
        (156  0.30 591)
        (147  0.30 591)
        (rest 0.3)
        (208  0.30 591)
        (196  0.30 591)
        (175  0.30 591)
        (196  0.30 591)
        (175  0.15 591)
        (156  0.15 591)
        (175  0.30 591)
        (196  0.30 591)
        (262  0.15 591)
        (294  0.15 591)
        (311  0.15 591)
        (294  0.15 591)
        (262  0.15 591)
        (233  0.15 591)
        (208  0.15 591)
        (196  0.15 591)
        (175  0.15 591)
        (466  0.15 591)
        (415  0.15 591)
        (392  0.15 591)
        (349  0.15 591)
        (311  0.15 591)
        (294  0.15 591)
        (262  0.15 591)
        (233  0.15 591)
        (262  0.15 591)
        (294  0.15 591)
        (262  0.15 591)
        (233  0.15 591)
        (208  0.15 591)
        (196  0.15 591)
        (175  0.15 591)
        (156  0.15 591)
        (415  0.15 591)
        (392  0.15 591)
        (349  0.15 591)
        (311  0.15 591)
        (294  0.15 591)
        (262  0.15 591)
        (233  0.15 591)
        (208  0.15 591)
        (233  0.15 591)
        (262  0.15 591)
        (233  0.15 591)
        (208  0.15 591)
        (196  0.15 591)
        (175  0.15 591)
        (156  0.15 591)
        (147  0.15 591)
        (392  0.15 591)
        (349  0.15 591)
        (311  0.15 591)
        (294  0.15 591)
        (262  0.15 591)
        (247  0.15 591)
        (220  0.15 591)
        (196  0.60 772)
        (196  0.60 772)
        (rest 0.15)
        (196  0.15 772)
        (220  0.15 772)
        (247  0.15 772)
        (262  0.15 772)
        (294  0.15 772)
        (311  0.15 772)
        (349  0.15 772)
        (392  0.15 772)
        (349  0.15 772)
        (415  0.15 772)
        (392  0.15 772)
        (349  0.15 772)
        (311  0.15 772)
        (294  0.15 772)
        (262  0.15 772)
        (247  0.30 772)
        (262  0.15 772)
        (494  0.15 772)
        (262  0.30 772)
        (196  0.30 772)
        (208  0.30 772)
        (262  0.15 772)
        (247  0.15 772)
        (262  0.30 772)
        (294  0.30 772)
        (196  0.30 772)
        (262  0.15 772)
        (247  0.15 772)
        (262  0.30 772)
        (294  0.30 772)
        (175  0.15 772)
        (196  0.15 772)
        (208  0.60 772)
        (196  0.15 772)
        (175  0.15 772)
        (156  0.60 772)
        (rest 0.3)
        (311  0.30 772)
        (294  0.30 772)
        (262  0.30 772)
        (392  0.30 772)
        (196  0.30 772)
        (262  3.60 268)
        (494  0.40 268)
        (rest 0.4)
        (494  0.40 268)
        (rest 0.4)
        (392  1.60 268)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 12/17/97 16:52'!
bachFugueVoice4On: aSound
    "Voice four of a fugue by J. S. Bach."

    ^ self noteSequenceOn: aSound from: #(
        (rest 61.2)
        (131  0.15 500)
        (123  0.15 500)
        (131  0.30 500)
        (98   0.30 500)
        (104  0.30 500)
        (131  0.15 500)
        (123  0.15 500)
        (131  0.30 500)
        (147  0.30 500)
        (98   0.30 500)
        (131  0.15 500)
        (123  0.15 500)
        (131  0.30 500)
        (147  0.30 500)
        (87   0.15 500)
        (98   0.15 500)
        (104  0.60 500)
        (98   0.15 500)
        (87   0.15 500)
        (78   0.60 500)
        (rest 0.3)
        (156  0.30 500)
        (147  0.30 500)
        (131  0.30 500)
        (196  0.30 500)
        (98   0.30 500)
        (131  3.60 268)
        (131  3.20 205)).
! !

!AbstractSound class methodsFor: 'examples-bach fugue' stamp: 'jm 1/5/98 17:45'!
stereoBachFugue
    "Play fugue by J. S. Bach in stereo using different timbres."
    "AbstractSound stereoBachFugue play"

    "(AbstractSound bachFugueVoice1On: FMSound flute1) play"
    "(AbstractSound bachFugueVoice1On: PluckedSound default) play"

    ^ MixedSound new
        add: (self bachFugueVoice1On: FMSound oboe1) pan: 0.2;
        add: (self bachFugueVoice2On: FMSound organ1) pan: 0.8;
        add: (self bachFugueVoice3On: PluckedSound default) pan: 0.4;
        add: (self bachFugueVoice4On: FMSound brass1) pan: 0.6.
! !


!AbstractSound class methodsFor: 'primitive generation' stamp: 'jm 1/21/98 17:08'!
cCodeForSoundPrimitives
    "Return a string containing the C code for the sound primitives. This string is pasted into a file, compiled, and linked into the virtual machine. Note that the virtual machine's primitive table must also be edited to make new primitives available."
    "AbstractSound cCodeForSoundPrimitives"

    ^ CCodeGenerator new codeStringForPrimitives: #(
        (FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
        (PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
        (SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
        (ReverbSound applyReverbTo:startingAt:count:)
    ).
! !


!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:12'!
initSounds  "AbstractSound initSounds"
    Sounds _ Dictionary new.
    (FMSound class organization listAtCategoryNamed: #instruments)
        do: [:soundName | Sounds at: soundName asString
                        put: (FMSound perform: soundName)]! !

!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'!
soundNamed: soundName
    ^ Sounds at: soundName! !

!AbstractSound class methodsFor: 'sounds' stamp: 'jm 3/4/98 10:29'!
soundNamed: soundName ifAbsent: aBlock

    ^ Sounds at: soundName ifAbsent: aBlock
! !

!AbstractSound class methodsFor: 'sounds' stamp: 'jm 5/16/1998 09:54'!
soundNamed: soundName put: aSound

    Sounds at: soundName put: aSound.
    Smalltalk at: #ScorePlayerMorph ifPresent: [:playerClass |
        playerClass allInstancesDo:
            [:player | player updateInstrumentsFromLibrary]].
! !

!AbstractSound class methodsFor: 'sounds' stamp: 'di 1/27/98 15:13'!
soundNames
    ^ Sounds keys! !
FileDirectory subclass: #AcornFileDirectory
    instanceVariableNames: ''
    classVariableNames: 'FormsAreLittleEndian '
    poolDictionaries: ''
    category: 'System-Files'!

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AcornFileDirectory class
    instanceVariableNames: ''!

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:24'!
byteReverseForm: aForm
    "Byte-reverse the words of the given Form's bitmap. Supports porting a Squeak image to the Acorn."

    | bits w reversedW |
    bits _ aForm bits.
    1 to: bits size do: [:i |
        w _ bits at: i.
        reversedW _ Integer
            byte1: (w digitAt: 4)
            byte2: (w digitAt: 3)
            byte3: (w digitAt: 2)
            byte4: (w digitAt: 1).
        bits at: i put: reversedW].
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:44'!
extensionDelimiter
    "Return the character used to delimit filename extensions. For the Acorn, use a slash, since that is what a dot gets converted to when loading files from foreign file systems."

    ^ $/
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 06:41'!
pathNameDelimiter

    ^ $.
! !

!AcornFileDirectory class methodsFor: 'platform specific' stamp: 'jm 3/27/98 09:25'!
platformSpecificStartup
    "Do platform-specific startup. This is a hook for starting up a default Squeak image on an Acorn, whose BitBlt expects Forms to have little-endian byte ordering."

    FormsAreLittleEndian ifNil: [FormsAreLittleEndian _ false].
    FormsAreLittleEndian ifTrue: [^ self].  "already converted"

    Form withAllSubclasses do: [:c |
        c allInstancesDo: [:f |
            "skip the Display, since it will be redrawn anyway"
            f == Display ifFalse: [self byteReverseForm: f]]].

    FormsAreLittleEndian _ true.
! !
SwikiAction subclass: #ActiveSwikiAction
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'ls 5/1/98 11:29'!
browse: pageRef from: request
    "Just reply with a page in HTML format"

    | formattedPage liveText|
    liveText _ HTMLformatter evalEmbedded: (pageRef text)
        with: request unlessContains: (self dangerSet).
    formattedPage _ pageRef copy.
    "Make a copy, then format the text."
    formattedPage formatted: (HTMLformatter swikify: liveText
            linkhandler: [:link | urlmap
                    linkFor: link
                    from: request peerName
                    storingTo: OrderedCollection new]).
    request reply: ((self formatterFor: 'page') format: formattedPage).
! !

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 2/4/98 12:52'!
dangerSet
    ^#('Smalltalk' 'view' 'open' 'perform:' 'FileStream' 'FileDirectory' 'fileIn' 'Compiler' 'halt'
    'PWS' 'Swiki')
! !

!ActiveSwikiAction methodsFor: 'as yet unclassified' stamp: 'tk 1/31/98 16:44'!
inputFrom: request
    "Take user's input and respond with a searchresult or store the edit"

    | coreRef page |
    coreRef _ request message size < 2
        ifTrue: ['1']
        ifFalse: [request message at: 2].
    coreRef = 'searchresult' ifTrue: [
        "If contains search string, do search"
        request reply: PWS crlf,
            (HTMLformatter evalEmbedded: (self fileContents: source, 'results.html')
                with: (urlmap searchFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))).
        ^ #return].
    (request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page"
        page _ urlmap
            storeID: coreRef
            text: (request fields at: 'text' ifAbsent: ['blank text'])
            from: request peerName.
        page user: request userID.
        ^ self].    "return self means do serve the edited page afterwards"
    "oops, a new kind!! -- but don't complain!! Could be for ActivePage!!"
"    Transcript show: 'Unknown data from client. '; show: request fields
printString; cr."! !
SketchMorph subclass: #ActorDroneMorph
    instanceVariableNames: 'running clan '
    classVariableNames: 'ClanCache OnTicksSelectorCache '
    poolDictionaries: ''
    category: 'Experimental-Miscellaneous'!
!ActorDroneMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
ActorDroneMorph comment:
'I am a class of ActorMorphs that all share the same behavior methods.  OnTicks defined for one of me is used for all of me as long as we are of the same clan.  Clan is a symbol that is our name.'!


!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/20/97 09:07'!
clan
    ^ clan! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 23:00'!
clan: aSymbol
    clan _ aSymbol! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/17/97 22:59'!
nameInModel
    ^ clan! !

!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/21/97 13:22'!
onTicksSelector
    "Cache the interned symbol.  Should intern: do this?"

    clan = ClanCache ifTrue: [^ OnTicksSelectorCache].
    ClanCache _ clan.
    ^ OnTicksSelectorCache _ (self nameInModel, 'OnTicks:') asSymbol
! !

!ActorDroneMorph methodsFor: 'all' stamp: 'sw 8/18/97 13:41'!
step

    running ifTrue: [
        self world model perform: self onTicksSelector with: self].
! !

!ActorDroneMorph methodsFor: 'all' stamp: 'tk 8/27/97 23:46'!
stepTime

    ^ 0! !
Object subclass: #ActorState
    instanceVariableNames: 'owningPlayer penDown penSize penColor fractionalPosition instantiatedUserScriptsDictionary '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Support'!
!ActorState commentStamp: 'di 5/22/1998 16:32' prior: 0!
Holds a record of data representing actor-like slots in the Morph, on behalf of an associated Player.  Presently also holds onto the scriptInstantion objects that represent active scripts in an instance, but this will probably change soon.!


!ActorState methodsFor: 'initialization' stamp: 'sw 4/30/1998 22:32'!
copyWithPlayerReferenceNilled
    "Answer a copy of the receiver in which all the items referring to the corresponding Player object are nilled out, for the purpose of being set up with fresh values, after the copy, by the caller"

    | holdPlayer holdScriptDict copy copyScriptDict |
    holdPlayer _ owningPlayer.
    owningPlayer _ nil.
    holdScriptDict _ self instantiatedUserScriptsDictionary.
    instantiatedUserScriptsDictionary _ nil.
    copy _ self deepCopy.
    owningPlayer _ holdPlayer.
    instantiatedUserScriptsDictionary _ holdScriptDict.
    holdScriptDict ifNotNil:
        [copyScriptDict _ IdentityDictionary new.
        holdScriptDict associationsDo:
            [:assoc |
                copyScriptDict add: (assoc key -> (assoc value copyWithPlayerObliterated))].
        copy instantiatedUserScriptsDictionary: copyScriptDict].
    ^ copy
! !

!ActorState methodsFor: 'initialization' stamp: 'sw 5/13/1998 16:37'!
initializeFor: aPlayer
    | aNewDictionary |
    owningPlayer _ aPlayer.
    instantiatedUserScriptsDictionary ifNil: [^ self].
    aNewDictionary _ IdentityDictionary new.
    instantiatedUserScriptsDictionary associationsDo:
        [:assoc |
            aNewDictionary at: assoc key put: (assoc value shallowCopy player: aPlayer)].
    instantiatedUserScriptsDictionary _ aNewDictionary.! !


!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'!
choosePenColor: evt
    evt hand changeColorTarget: owningPlayer costume selector: #penColor:.
! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:44'!
choosePenSize
    | menu sz |
    menu _ CustomMenu new.
    1 to: 10 do: [:w | menu add: w printString action: w].
    sz _ menu startUp.
    sz ifNotNil: [penSize _ sz]! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:16'!
defaultPenColor
    ^ Color blue! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 15:03'!
defaultPenSize
    ^ 1! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:35'!
getPenColor
    penColor ifNil: [penColor _ self defaultPenColor].
    ^ penColor! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:40'!
getPenDown
    ^ penDown == true! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:43'!
getPenSize
    penSize ifNil: [penSize _ self defaultPenSize].
    ^ penSize! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:07'!
liftPen
    penDown _ false! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 14:58'!
lowerPen
    penDown _ true! !

!ActorState methodsFor: 'pen' stamp: 'sw 2/4/98 18:03'!
penColor: aColor
    penColor _ aColor! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:51'!
setPenColor: aColor
    penColor _ aColor
! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:47'!
setPenDown: aBoolean
    penDown _ aBoolean! !

!ActorState methodsFor: 'pen' stamp: 'sw 4/22/1998 13:45'!
setPenSize: aNumber
    penSize _ aNumber! !


!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:34'!
fractionalPosition
    "Return my player's costume's position including the fractional part. This allows the precise position to be retained to avoid cummulative rounding errors, while letting Morphic do all its calculations with integer pixel coordinates. See the implementation of forward:."

    ^ fractionalPosition
! !

!ActorState methodsFor: 'position' stamp: 'jm 4/24/1998 21:31'!
fractionalPosition: aPoint

    fractionalPosition _ aPoint asFloatPoint.
! !


!ActorState methodsFor: 'script instantiations' stamp: 'sw 4/9/98 22:35'!
instantiatedUserScriptsDictionary
    instantiatedUserScriptsDictionary ifNil: [instantiatedUserScriptsDictionary _ IdentityDictionary new].
    ^ instantiatedUserScriptsDictionary! !

!ActorState methodsFor: 'script instantiations' stamp: 'sw 4/30/1998 21:51'!
instantiatedUserScriptsDictionary: aDict
    "Used for copying code only"
    instantiatedUserScriptsDictionary _ aDict! !


!ActorState methodsFor: 'other' stamp: 'sw 4/22/1998 17:02'!
addPlayerMenuItemsTo: aMenu hand: aHandMorph
    self getPenDown
        ifTrue: [aMenu add: 'pen up' action: #liftPen]
        ifFalse: [aMenu add: 'pen down' action: #lowerPen].
    aMenu add: 'pen size' action: #choosePenSize.
    aMenu add: 'pen color' action: #choosePenColor:.! !

!ActorState methodsFor: 'other' stamp: 'sw 4/13/1998 19:36'!
costume
    ^ owningPlayer costume! !

!ActorState methodsFor: 'other' stamp: 'sw 5/12/1998 23:35'!
printOn: aStream
    aStream nextPutAll: 'ActorState for ', owningPlayer externalName, ' '.
    penDown ifNotNil: [aStream cr; nextPutAll: 'penDown ', penDown printString].
    penColor ifNotNil: [aStream cr; nextPutAll: 'penColor ', penColor printString].
    penSize ifNotNil: [aStream cr; nextPutAll: 'penSize ', penSize printString].
    instantiatedUserScriptsDictionary ifNotNil:
        [aStream cr; nextPutAll:
            '+ ', instantiatedUserScriptsDictionary size printString, ' user scripts'].
! !
RectangleMorph subclass: #AlignmentMorph
    instanceVariableNames: 'orientation centering hResizing vResizing inset minCellSize openToDragNDrop layoutNeeded '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Basic'!

!AlignmentMorph methodsFor: 'initialization' stamp: 'sw 9/10/97 14:47'!
initialize

    super initialize.
    borderWidth _ 0.
    orientation _ #horizontal.    "#horizontal or #vertical  or #free"
    centering _ #topLeft.        "#topLeft, #center, or #bottomRight"
    hResizing _ #spaceFill.        "#spaceFill, #shrinkWrap, or #rigid"
    vResizing _ #spaceFill.        "#spaceFill, #shrinkWrap, or #rigid"
    inset _ 2.                    "pixels inset within owner's bounds"
    minCellSize _ 0.                "minimum space between morphs; useful for tables"
    openToDragNDrop _ false.    "objects can be dropped in or dragged out"
    layoutNeeded _ true.
    color _ Color r: 0.8 g: 1.0 b: 0.8.
! !


!AlignmentMorph methodsFor: 'classification' stamp: 'sw 5/13/1998 14:50'!
demandsBoolean
    "unique to the TEST frame inside a CompoundTileMorph"

    ^ self hasProperty: #demandsBoolean! !

!AlignmentMorph methodsFor: 'classification' stamp: 'di 5/7/1998 01:20'!
isAlignmentMorph

    ^ true
! !


!AlignmentMorph methodsFor: 'accessing'!
centering

    ^ centering
! !

!AlignmentMorph methodsFor: 'accessing'!
centering: aSymbol
    "Set the minor dimension alignment to #topLeft, #center, or #bottomRight."

    centering _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 2/13/98 16:15'!
chooseOrientation
    | aMenu emphases reply |
    emphases _ #(vertical horizontal).
    aMenu _ EmphasizedMenu selections: emphases.
    aMenu onlyBoldItem: (emphases indexOf: orientation).
    reply _ aMenu startUpWithCaption: 'Choose orientation'.
    (reply == nil or: [reply == orientation]) ifTrue: [^ self].
    self orientation: reply.
    self layoutChanged! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 10/19/97 23:39'!
configureForKids
    self openToDragNDrop: false.
    super configureForKids
! !

!AlignmentMorph methodsFor: 'accessing'!
hResizing

    ^ hResizing
! !

!AlignmentMorph methodsFor: 'accessing'!
hResizing: aSymbol
    "Set the horizontal resizing style to #spaceFill, #shrinkWrap, or #rigid."

    hResizing _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing'!
inset

    ^ inset
! !

!AlignmentMorph methodsFor: 'accessing'!
inset: anInteger
    "Set the amount of padding within my bounds to the given amount."

    inset _ anInteger.
! !

!AlignmentMorph methodsFor: 'accessing'!
minCellSize

    ^ minCellSize
! !

!AlignmentMorph methodsFor: 'accessing'!
minCellSize: anInteger
    "Set the minium space per submorph to the given size. Useful for making tables."

    minCellSize _ anInteger.
! !

!AlignmentMorph methodsFor: 'accessing'!
openCloseDragNDrop
    "Toggle this morph's ability to add and remove morphs via drag-n-drop."

    openToDragNDrop _ openToDragNDrop not.
! !

!AlignmentMorph methodsFor: 'accessing'!
openToDragNDrop

    ^ openToDragNDrop
! !

!AlignmentMorph methodsFor: 'accessing'!
openToDragNDrop: aBoolean
    "Set this morph's ability to add and remove morphs via drag-n-drop."

    openToDragNDrop _ aBoolean.
! !

!AlignmentMorph methodsFor: 'accessing'!
orientation

    ^ orientation
! !

!AlignmentMorph methodsFor: 'accessing' stamp: 'sw 9/10/97 14:55'!
orientation: aSymbol
    "Set the major layout dimension to #horizontal or #vertical or #free"

    orientation _ aSymbol.
! !

!AlignmentMorph methodsFor: 'accessing'!
vResizing

    ^ vResizing
! !

!AlignmentMorph methodsFor: 'accessing'!
vResizing: aSymbol
    "Set the vertical resizing style to #spaceFill, #shrinkWrap, or #rigid."

    vResizing _ aSymbol.
! !


!AlignmentMorph methodsFor: 'geometry' stamp: 'jm 7/8/97 08:26'!
layoutChanged

    "invalidate old fullBounds in case we shrink"
    fullBounds ifNotNil: [self invalidRect: fullBounds].

    super layoutChanged.
    layoutNeeded _ true.
! !


!AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'!
acceptDroppingMorph: aMorph event: evt
    "Allow the user to add submorphs just by dropping them on this morph."
    self privateAddMorph: aMorph atIndex: (self insertionIndexFor: aMorph).
    self changed.
    self layoutChanged.
! !

!AlignmentMorph methodsFor: 'dropping/grabbing'!
allowSubmorphExtraction

    ^ openToDragNDrop
! !

!AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:19'!
rootForGrabOf: aMorph

    | root |
    openToDragNDrop ifFalse: [^ super rootForGrabOf: aMorph].
    root _ aMorph.
    [root == self] whileFalse:
        [root owner = self ifTrue: [^ root].
        root _ root owner].
    ^ super rootForGrabOf: aMorph
! !

!AlignmentMorph methodsFor: 'dropping/grabbing'!
wantsDroppedMorph: aMorph event: evt
    "Supports adding morphs by dropping."

    ^ openToDragNDrop! !


!AlignmentMorph methodsFor: 'layout'!
fullBounds
    "This is the hook that triggers lazy re-layout of layout morphs. It works because layoutChanged clears the fullBounds cache. Once per cycle, the fullBounds is requested from every morph in the world, and that request gets propagated through the entire submorph hierarchy, causing re-layout where needed. Note that multiple layoutChanges to the same morph can be done with little cost, since the layout is only done when the morph needs to be displayed."

    fullBounds ifNil: [
        layoutNeeded ifTrue: [
            self resizeIfNeeded.
            self fixLayout.
            "compute fullBounds before calling changed to avoid infinite recursion"
            super fullBounds.  "updates cache"
            self changed.  "report change due to layout"
            layoutNeeded _ false]].
    ^ super fullBounds
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
maxWidth
    "Return the minimum width for this morph."

    | spaceNeeded minW |
    hResizing = #rigid ifTrue: [^ self fullBounds width].
    submorphs isEmpty ifTrue: [^ self minWidthWhenEmpty].
    orientation == #horizontal ifTrue:
        [spaceNeeded _ 2 * (inset + borderWidth).
        submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize)]].
    orientation == #vertical ifTrue:
        [minW _ 0.
        submorphs do: [:m | minW _ minW max: m minWidth].
        spaceNeeded _ minW + (2 * (inset + borderWidth))].
    ^ spaceNeeded! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
minHeight
    "Return the minimum height for this morph."

    | minH spaceNeeded |
    vResizing = #rigid ifTrue: [^ self fullBounds height].
    submorphs isEmpty ifTrue: [^ self minHeightWhenEmpty].
    orientation == #horizontal ifTrue:
        [minH _ 0.
        submorphs do: [:m | minH _ minH max: m minHeight].
        spaceNeeded _ minH + (2 * (inset + borderWidth))].
    orientation == #vertical ifTrue:
        [spaceNeeded _ 2 * (inset + borderWidth).
        submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize)]].

    ^ spaceNeeded
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'!
minHeightWhenEmpty

    ^ 2
! !

!AlignmentMorph methodsFor: 'layout' stamp: 'sw 2/13/98 16:15'!
minWidth
    "Return the minimum width for this morph."

    | spaceNeeded minW |
    hResizing = #rigid ifTrue: [^ self fullBounds width].
    submorphs isEmpty ifTrue: [^ self minWidthWhenEmpty].
    orientation == #horizontal ifTrue:
        [spaceNeeded _ 2 * (inset + borderWidth).
        submorphs do: [:m | spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize)]].
    orientation == #vertical ifTrue:
        [minW _ 0.
        submorphs do: [:m | minW _ minW max: m minWidth].
        spaceNeeded _ minW + (2 * (inset + borderWidth))].
    ^ spaceNeeded! !

!AlignmentMorph methodsFor: 'layout' stamp: 'jm 1/29/98 19:43'!
minWidthWhenEmpty

    ^ 2
! !


!AlignmentMorph methodsFor: 'menu' stamp: 'sw 9/11/97 16:07'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    aCustomMenu add: 'orientation...' action: #chooseOrientation.
    aCustomMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
            action: #openCloseDragNDrop.
! !


!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
extraSpacePerMorph

    | spaceFillingMorphs spaceNeeded extra |
    spaceFillingMorphs _ 0.
    spaceNeeded _ 2 * (inset + borderWidth).
    orientation = #horizontal ifTrue: [
        submorphs do: [:m |
            spaceNeeded _ spaceNeeded + (m minWidth max: minCellSize).
            (m isAlignmentMorph and: [m hResizing = #spaceFill])
                ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].
        extra _ (bounds width - spaceNeeded) max: 0.
    ] ifFalse: [
        submorphs do: [:m |
            spaceNeeded _ spaceNeeded + (m minHeight max: minCellSize).
            (m isAlignmentMorph and: [m vResizing = #spaceFill])
                ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]].
        extra _ (bounds height - spaceNeeded) max: 0].

    (submorphs size <= 1 or: [spaceFillingMorphs <= 1]) ifTrue: [^ extra].
    ^ extra // spaceFillingMorphs
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 2/13/98 16:15'!
fixLayout

    | extraPerMorph nextPlace space |
    extraPerMorph _ self extraSpacePerMorph.
    orientation = #horizontal
        ifTrue: [nextPlace _ bounds left + inset + borderWidth]
        ifFalse: [nextPlace _ bounds top + inset + borderWidth].
    submorphs do: [:m |
        space _ self placeAndSize: m at: nextPlace padding: extraPerMorph.
        nextPlace _ nextPlace + space].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 9/10/97 14:54'!
insertionIndexFor: aMorph
    "Return the index at which the given morph should be inserted into the submorphs of the receiver."

    | newCenter |
    newCenter _ aMorph fullBounds center.
    orientation == #horizontal ifTrue:
        [submorphs doWithIndex: [:m :i |
            newCenter x < m fullBounds center x ifTrue: [^ i]]].
    orientation == #vertical ifTrue:
        [submorphs doWithIndex: [:m :i |
            newCenter y < m fullBounds center y ifTrue: [^ i]]].

    ^ submorphs size + 1  "insert after the last submorph"
! !

!AlignmentMorph methodsFor: 'private'!
layoutInWidth: w height: h
    "Adjust the size of the receiver in its space-filling dimensions during layout. This message is sent to only to layout submorphs."

    ((hResizing = #spaceFill) and: [bounds width ~= w]) ifTrue: [
        bounds _ bounds origin extent: (w @ bounds height).
        fullBounds _ nil.
        layoutNeeded _ true].

    ((vResizing = #spaceFill) and: [bounds height ~= h]) ifTrue: [
        bounds _ bounds origin extent: (bounds width @ h).
        fullBounds _ nil.
        layoutNeeded _ true].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
placeAndSize: m at: nextPlace padding: padding

    | space totalInset fullBnds left top |
    totalInset _ inset + borderWidth.
    orientation = #horizontal ifTrue: [
        space _ m minWidth max: minCellSize.
        m isAlignmentMorph ifTrue: [
            (m hResizing = #spaceFill) ifTrue: [space _ space + padding].
            m layoutInWidth: space height: (bounds height - (2 * totalInset))].
    ] ifFalse: [
        space _ m minHeight max: minCellSize.
        m isAlignmentMorph ifTrue: [
            (m vResizing = #spaceFill) ifTrue: [space _ space + padding].
            m layoutInWidth: (bounds width - (2 * totalInset)) height: space]].

    fullBnds _ m fullBounds.
    orientation = #horizontal ifTrue: [
        left _ nextPlace.
        centering = #topLeft
            ifTrue: [top _ bounds top + totalInset].
        centering = #bottomRight
            ifTrue: [top _ bounds bottom - totalInset - fullBnds height].
        centering = #center
            ifTrue: [top _ bounds top + ((bounds height - fullBnds height) // 2)].
    ] ifFalse: [
        top _ nextPlace.
        centering = #topLeft
            ifTrue: [left _ bounds left + totalInset].
        centering = #bottomRight
            ifTrue: [left _ bounds right - totalInset - fullBnds width].
        centering = #center
            ifTrue: [left _ bounds left + ((bounds width - fullBnds width) // 2)]].

    m position: (left + (m bounds left - fullBnds left)) @ (top + (m bounds top - fullBnds top)).
    ^ space
! !

!AlignmentMorph methodsFor: 'private' stamp: 'di 5/7/1998 01:21'!
resizeIfNeeded
    "Resize this morph if it is space-filling or shrink-wrap and its owner is not a layout morph."

    | newWidth newHeight |
    newWidth _ bounds width.
    newHeight _ bounds height.

    (owner == nil or: [owner isAlignmentMorph not]) ifTrue: [
        "if spaceFill and not in a LayoutMorph, grow to enclose submorphs"
        hResizing = #spaceFill ifTrue: [newWidth _ self minWidth max: self bounds width].
        vResizing = #spaceFill ifTrue: [newHeight _ self minHeight max: self bounds height]].

    "if shrinkWrap, adjust size to just fit around submorphs"
    hResizing = #shrinkWrap ifTrue: [newWidth _ self minWidth].
    vResizing = #shrinkWrap ifTrue: [newHeight _ self minHeight].

    ((newWidth ~= bounds width) or: [newHeight ~= bounds height]) ifTrue: [
        "bounds really changed; flush fullBounds cache and fix submorph layouts"
        bounds _ bounds origin extent: newWidth@newHeight.
        fullBounds _ nil].
! !

!AlignmentMorph methodsFor: 'private' stamp: 'sw 5/6/1998 15:58'!
wantsKeyboardFocusFor: aSubmorph
    aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true].
    ^ super wantsKeyboardFocusFor: aSubmorph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AlignmentMorph class
    instanceVariableNames: ''!

!AlignmentMorph class methodsFor: 'instance creation'!
newColumn

    ^ self new
        orientation: #vertical;
        hResizing: #spaceFill;
        vResizing: #spaceFill
! !

!AlignmentMorph class methodsFor: 'instance creation'!
newRow

    ^ self new
        orientation: #horizontal;
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        borderWidth: 0
! !

!AlignmentMorph class methodsFor: 'instance creation' stamp: 'jm 5/4/1998 12:18'!
newSpacer: aColor
    "Answer a space-filling instance of me of the given color."

    ^ self new
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        inset: 0;
        borderWidth: 0;
        color: aColor.
! !
Path subclass: #Arc
    instanceVariableNames: 'quadrant radius center '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Paths'!
!Arc commentStamp: 'di 5/22/1998 16:32' prior: 0!
Arc comment:
'Arcs are an unusual implementation of splines
due to Ted Kaehler.  Imagine two lines that meet at a corner.
Now imagine two moving points; one moves from the corner to
the end on one line, the other moves from the end of the other
line in to the corner.  Now imagine a series of lines drawn
between those moving points at each step along the way (they
form a sort of spider web pattern).  By connecting segments
of the intersecting lines, a smooth curve is achieved that is
tangent to both of the original lines.  Voila.'!


!Arc methodsFor: 'accessing'!
center
    "Answer the point at the center of the receiver."

    ^center! !

!Arc methodsFor: 'accessing'!
center: aPoint
    "Set aPoint to be the receiver's center."

    center _ aPoint! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger
    "The receiver is defined by a point at the center and a radius. The
    quadrant is not reset."

    center _ aPoint.
    radius _ anInteger! !

!Arc methodsFor: 'accessing'!
center: aPoint radius: anInteger quadrant: section
    "Set the receiver's quadrant to be the argument, section. The size of the
    receiver is defined by the center and its radius."

    center _ aPoint.
    radius _ anInteger.
    quadrant _ section! !

!Arc methodsFor: 'accessing'!
quadrant
    "Answer the part of the circle represented by the receiver."
    ^quadrant! !

!Arc methodsFor: 'accessing'!
quadrant: section
    "Set the part of the circle represented by the receiver to be the argument,
    section."

    quadrant _ section! !

!Arc methodsFor: 'accessing'!
radius
    "Answer the receiver's radius."

    ^radius! !

!Arc methodsFor: 'accessing'!
radius: anInteger
    "Set the receiver's radius to be the argument, anInteger."

    radius _ anInteger! !


!Arc methodsFor: 'display box access'!
computeBoundingBox
    | aRectangle aPoint |
    aRectangle _ center - radius + form offset extent: form extent + (radius * 2) asPoint.
    aPoint _ center + form extent.
    quadrant = 1 ifTrue: [^ aRectangle encompass: center x @ aPoint y].
    quadrant = 2 ifTrue: [^ aRectangle encompass: aPoint x @ aPoint y].
    quadrant = 3 ifTrue: [^ aRectangle encompass: aPoint x @ center y].
    quadrant = 4 ifTrue: [^ aRectangle encompass: center x @ center y]! !


!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

    | nSegments line angle sin cos xn yn xn1 yn1 |
    nSegments _ 12.0.
    line _ Line new.
    line form: self form.
    angle _ 90.0 / nSegments.
    sin _ (angle * (2 * Float pi / 360.0)) sin.
    cos _ (angle * (2 * Float pi / 360.0)) cos.
    quadrant = 1
        ifTrue:
            [xn _ radius asFloat.
            yn _ 0.0].
    quadrant = 2
        ifTrue:
            [xn _ 0.0.
            yn _ 0.0 - radius asFloat].
    quadrant = 3
        ifTrue:
            [xn _ 0.0 - radius asFloat.
            yn _ 0.0].
    quadrant = 4
        ifTrue:
            [xn _ 0.0.
            yn _ radius asFloat].
    nSegments asInteger
        timesRepeat:
            [xn1 _ xn * cos + (yn * sin).
            yn1 _ yn * cos - (xn * sin).
            line beginPoint: center + (xn asInteger @ yn asInteger).
            line endPoint: center + (xn1 asInteger @ yn1 asInteger).
            line
                displayOn: aDisplayMedium
                at: aPoint
                clippingBox: clipRect
                rule: anInteger
                fillColor: aForm.
            xn _ xn1.
            yn _ yn1]! !

!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

    | newArc tempCenter |
    newArc _ Arc new.
    tempCenter _ aTransformation applyTo: self center.
    newArc center: tempCenter x asInteger @ tempCenter y asInteger.
    newArc quadrant: self quadrant.
    newArc radius: (self radius * aTransformation scale x) asInteger.
    newArc form: self form.
    newArc
        displayOn: aDisplayMedium
        at: 0 @ 0
        clippingBox: clipRect
        rule: anInteger
        fillColor: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Arc class
    instanceVariableNames: ''!

!Arc class methodsFor: 'examples'!
example
    "Click the button somewhere on the screen. The designated point will
    be the center of an Arc with radius 50 in the 4th quadrant."

    | anArc aForm |
    aForm _ Form extent: 1 @ 30.    "make a long thin Form for display"
    aForm fillBlack.                        "turn it black"
    anArc _ Arc new.
    anArc form: aForm.                    "set the form for display"
    anArc radius: 50.0.
    anArc center: Sensor waitButton.
    anArc quadrant: 4.
    anArc displayOn: Display.
    Sensor waitButton

    "Arc example"! !
ArrayedCollection variableSubclass: #Array
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Arrayed'!
!Array commentStamp: 'di 5/22/1998 16:32' prior: 0!
Array comment:
'I present an ArrayedCollection whose elements are objects.'!


!Array methodsFor: 'comparing'!
hash
    "Make sure that equal (=) arrays hash equally."

    self size = 0 ifTrue: [^17171].
    ^(self at: 1) hash + (self at: self size) hash! !

!Array methodsFor: 'comparing'!
hashMappedBy: map
    "Answer what my hash would be if oops changed according to map."

    self size = 0 ifTrue: [^self hash].
    ^(self first hashMappedBy: map) + (self last hashMappedBy: map)! !


!Array methodsFor: 'converting'!
asArray
    "Answer with the receiver itself."

    ^self! !

!Array methodsFor: 'converting'!
elementsExchangeIdentityWith: otherArray
    <primitive: 128>
    self primitiveFailed! !

!Array methodsFor: 'converting'!
evalStrings
       "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
              each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        each class == String ifTrue: [
            it _ Compiler evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !


!Array methodsFor: 'printing'!
isLiteral

    self detect: [:element | element isLiteral not] ifNone: [^true].
    ^false! !

!Array methodsFor: 'printing' stamp: 'di 6/20/97 09:09'!
printOn: aStream
    aStream nextPut: $(.
    self do: [:element | element printOn: aStream. aStream space].
    aStream nextPut: $)! !

!Array methodsFor: 'printing'!
storeOn: aStream
    "Use the literal form if possible."

    self isLiteral
        ifTrue:
            [aStream nextPut: $#; nextPut: $(.
            self do:
                [:element |
                element printOn: aStream.
                aStream space].
            aStream nextPut: $)]
        ifFalse: [super storeOn: aStream]! !


!Array methodsFor: 'private' stamp: 'di 8/15/97 09:55'!
hasLiteralSuchThat: litBlock
    "Answer true if litBlock returns true for any literal in this array, even if imbedded in further array structure.  This method is only intended for private use by CompiledMethod hasLiteralSuchThat:"
    | lit |
    1 to: self size do:
        [:index | lit _ self at: index.
        (litBlock value: lit) ifTrue: [^ true].
        (lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
    ^false! !

!Array methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart
    "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
    <primitive: 105>
    super replaceFrom: start to: stop with: replacement startingAt: repStart! !
ArrayedCollection subclass: #Array2D
    instanceVariableNames: 'width contents '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Arrayed'!

!Array2D methodsFor: 'access'!
at: i at: j
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i! !

!Array2D methodsFor: 'access'!
at: i at: j add: value
    "add value to the element"
    | index |
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    index _ (j - 1) * width + i.
    ^ contents at: index put: (contents at: index) + value! !

!Array2D methodsFor: 'access'!
at: i at: j put: value
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i put: value! !

!Array2D methodsFor: 'access'!
atAllPut: value
    "Initialize"
    contents atAllPut: value! !

!Array2D methodsFor: 'access'!
atCol: i
    "Fetch a whole column.  6/20/96 tk"

    | ans |
    ans _ contents class new: self height.
    1 to: self height do: [:ind |
        ans at: ind put: (self at: i at: ind)].
    ^ ans! !

!Array2D methodsFor: 'access'!
atCol: i put: list
    "Put in a whole column.
     hold first index constant"

    list size = self height ifFalse: [self error: 'wrong size'].
    list doWithIndex: [:value :j |
        self at: i at: j put: value].! !

!Array2D methodsFor: 'access'!
atRow: j
    "Fetch a whole row.  6/20/96 tk"

    ^ contents copyFrom: (j - 1) * width + 1 to: (j) * width! !

!Array2D methodsFor: 'access'!
atRow: j put: list
    "Put in a whole row.
     hold second index constant"

    list size = self width ifFalse: [self error: 'wrong size'].
    list doWithIndex: [:value :i |
        self at: i at: j put: value].! !

!Array2D methodsFor: 'access'!
do: aBlock
    "Iterate with X varying most quickly.  6/20/96 tk"
    ^ contents do: aBlock! !

!Array2D methodsFor: 'access'!
extent
    ^ width @ self height! !

!Array2D methodsFor: 'access'!
extent: extent fromArray: anArray
    "Load this 2-D array up from a 1-D array.  X varies most quickly.  6/20/96 tk"

    extent x * extent y = anArray size ifFalse: [
        ^ self error: 'dimensions don''t match'].
    width _ extent x.
    contents _ anArray.! !

!Array2D methodsFor: 'access'!
height
    "second dimension"
    "no need to save it"
    ^ contents size // width! !

!Array2D methodsFor: 'access'!
width
    "first dimension"
    ^ width! !

!Array2D methodsFor: 'access'!
width: x height: y type: class
    "Set the number of elements in the first and
    second dimensions.  class can be Array or String or ByteArray."

    contents == nil ifFalse: [self error: 'No runtime size change yet'].
        "later move all the elements to the new sized array"
    width _ x.
    contents _ class new: width*y.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Array2D class
    instanceVariableNames: ''!

!Array2D class methodsFor: 'as yet unclassified'!
new
    "Override ArrayedCollection.  6/20/96 tk"
    ^ self basicNew! !

!Array2D class methodsFor: 'as yet unclassified'!
new: size
    "Use (self new width: x height: y type: Array)   6/20/96 tk"
    ^ self shouldNotImplement! !
SequenceableCollection subclass: #ArrayedCollection
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Abstract'!
!ArrayedCollection commentStamp: 'di 5/22/1998 16:32' prior: 0!
ArrayedCollection comment:
'I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.'!


!ArrayedCollection methodsFor: 'accessing'!
size
    "Primitive. Answer the number of indexable fields in the receiver. This
    value is the same as the largest legal subscript. Primitive is specified
    here to override SequenceableCollection size. Essential. See Object
    documentation whatIsAPrimitive. "

    <primitive: 62>
    ^self basicSize! !


!ArrayedCollection methodsFor: 'adding'!
add: newObject

    self shouldNotImplement! !


!ArrayedCollection methodsFor: 'printing'!
storeOn: aStream

    aStream nextPutAll: '(('.
    aStream nextPutAll: self class name.
    aStream nextPutAll: ' new: '.
    aStream store: self size.
    aStream nextPut: $).
    (self storeElementsFrom: 1 to: self size on: aStream)
        ifFalse: [aStream nextPutAll: '; yourself'].
    aStream nextPut: $)! !


!ArrayedCollection methodsFor: 'private'!
defaultElement

    ^nil! !

!ArrayedCollection methodsFor: 'private'!
fill: numElements fromStack: aContext
    "Fill me with numElements elements, popped in reverse order from
     the stack of aContext.  Do not call directly: this is called indirectly by {1. 2. 3}
     constructs."

    aContext pop: numElements toIndexable: self! !

!ArrayedCollection methodsFor: 'private'!
storeElementsFrom: firstIndex to: lastIndex on: aStream

    | noneYet defaultElement arrayElement |
    noneYet _ true.
    defaultElement _ self defaultElement.
    firstIndex to: lastIndex do:
        [:index |
        arrayElement _ self at: index.
        arrayElement = defaultElement
            ifFalse:
                [noneYet
                    ifTrue: [noneYet _ false]
                    ifFalse: [aStream nextPut: $;].
                aStream nextPutAll: ' at: '.
                aStream store: index.
                aStream nextPutAll: ' put: '.
                aStream store: arrayElement]].
    ^noneYet! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArrayedCollection class
    instanceVariableNames: ''!

!ArrayedCollection class methodsFor: 'instance creation'!
fromBraceStack: itsSize
    "Answer an instance of me with itsSize elements, popped in reverse order from
     the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
     constructs."

    ^ (self new: itsSize) fill: itsSize fromStack: thisContext sender! !

!ArrayedCollection class methodsFor: 'instance creation'!
new
    "Answer a new instance of me, with size = 0."

    ^self new: 0! !

!ArrayedCollection class methodsFor: 'instance creation'!
new: size withAll: value
    "Answer an instance of me, with number of elements equal to size, each
    of which refers to the argument, value."

    ^(self new: size) atAllPut: value! !

!ArrayedCollection class methodsFor: 'instance creation'!
newFrom: aCollection
    "Answer an instance of me containing the same elements as aCollection."
    | newArray |
    newArray _ self new: aCollection size.
    1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)].
    ^ newArray

"    Array newFrom: {1. 2. 3}
    {1. 2. 3} as: Array
    {1. 2. 3} as: ByteArray
    {$c. $h. $r} as: String
    {$c. $h. $r} as: Text
"! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: anObject
    "Answer a new instance of me, containing only anObject."

    | newCollection |
    newCollection _ self new: 1.
    newCollection at: 1 put: anObject.
    ^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject
    "Answer a new instance of me, containing firstObject and secondObject."

    | newCollection |
    newCollection _ self new: 2.
    newCollection at: 1 put: firstObject.
    newCollection at: 2 put: secondObject.
    ^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject
    "Answer a new instance of me, containing only the three arguments as
    elements."

    | newCollection |
    newCollection _ self new: 3.
    newCollection at: 1 put: firstObject.
    newCollection at: 2 put: secondObject.
    newCollection at: 3 put: thirdObject.
    ^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject
    "Answer a new instance of me, containing only the three arguments as
    elements."

    | newCollection |
    newCollection _ self new: 4.
    newCollection at: 1 put: firstObject.
    newCollection at: 2 put: secondObject.
    newCollection at: 3 put: thirdObject.
    newCollection at: 4 put: fourthObject.
    ^newCollection! !

!ArrayedCollection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
    "Answer a new instance of me, containing only the five arguments as
    elements."

    | newCollection |
    newCollection _ self new: 5.
    newCollection at: 1 put: firstObject.
    newCollection at: 2 put: secondObject.
    newCollection at: 3 put: thirdObject.
    newCollection at: 4 put: fourthObject.
    newCollection at: 5 put: fifthObject.
    ^newCollection! !
ParseNode subclass: #AssignmentNode
    instanceVariableNames: 'variable value '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!
!AssignmentNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
AssignmentNode comment: 'I represent a (var_expr) construct.'!


!AssignmentNode methodsFor: 'initialize-release'!
toDoIncrement: var
    var = variable ifFalse: [^ nil].
    (value isMemberOf: MessageNode)
        ifTrue: [^ value toDoIncrement: var]
        ifFalse: [^ nil]! !

!AssignmentNode methodsFor: 'initialize-release'!
value
    ^ value! !

!AssignmentNode methodsFor: 'initialize-release'!
variable: aVariable value: expression

    variable _ aVariable.
    value _ expression! !

!AssignmentNode methodsFor: 'initialize-release'!
variable: aVariable value: expression from: encoder

    (aVariable isMemberOf: MessageNode)
        ifTrue: [^aVariable store: expression from: encoder].
    variable _ aVariable.
    value _ expression! !


!AssignmentNode methodsFor: 'code generation'!
emitForEffect: stack on: aStream

    value emitForValue: stack on: aStream.
    variable emitStorePop: stack on: aStream! !

!AssignmentNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

    value emitForValue: stack on: aStream.
    variable emitStore: stack on: aStream! !

!AssignmentNode methodsFor: 'code generation'!
sizeForEffect: encoder

    ^(value sizeForValue: encoder)
        + (variable sizeForStorePop: encoder)! !

!AssignmentNode methodsFor: 'code generation'!
sizeForValue: encoder

    ^(value sizeForValue: encoder)
        + (variable sizeForStore: encoder)! !


!AssignmentNode methodsFor: 'printing'!
printOn: aStream indent: level

    variable printOn: aStream indent: level.
    aStream nextPutAll: ' _ '.
    value printOn: aStream indent: level + 2! !

!AssignmentNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p

    p < 4 ifTrue: [aStream nextPutAll: '('].
    self printOn: aStream indent: level.
    p < 4 ifTrue: [aStream nextPutAll: ')']! !


!AssignmentNode methodsFor: 'equation translation'!
variable
    ^variable! !


!AssignmentNode methodsFor: 'C translation'!
asTranslatorNode
    ^TAssignmentNode new
        setVariable: variable asTranslatorNode
        expression: value asTranslatorNode! !
TileMorph subclass: #AssignmentTileMorph
    instanceVariableNames: 'assignmentRoot assignmentSuffix dataType '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Tiles'!

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 12/12/97 01:24'!
arrowAction: delta
    | index aList |
    owner ifNil: [^ self].
    operatorOrExpression ifNotNil:
        [aList _ #(: Incr: Decr: Mult:).
        index _ aList indexOf: assignmentSuffix asSymbol.
        index  > 0 ifTrue:
            [self setAssignmentSuffix: (aList atWrap: index + delta).
            self acceptNewLiteral]]! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'!
computeOperatorOrExpression
    | aSuffix |
    operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol.
    aSuffix _ ScriptingSystem wordingForAssignmentSuffix: assignmentSuffix.
    operatorReadoutString _ assignmentRoot, ' ', aSuffix.
     self line1: operatorReadoutString.
    dataType == #number ifTrue: [self addArrows] ! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 11/17/97 14:36'!
initialize
    super initialize.
    type _ #operator.
    assignmentSuffix _ ':'! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 5/2/1998 15:00'!
setAssignmentSuffix: aString
    assignmentSuffix _ aString.
    self computeOperatorOrExpression.
    type _ #operator.
     self line1: (ScriptingSystem wordingForOperator: operatorOrExpression).
    self addArrows; updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 2/16/98 01:12'!
setRoot: aString dataType: aSymbol
    assignmentRoot _ aString.
    assignmentSuffix _ ':'.
    dataType _ aSymbol.
    self updateLiteralLabel! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'!
storeCodeOn: aStream
    aStream nextPutAll: ' assign', (assignmentSuffix copyWithout: $:), 'Getter: #'.
    aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot).
    aStream nextPutAll: ' setter: #'.
    aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot).
    aStream nextPutAll: ' amt: '! !

!AssignmentTileMorph methodsFor: 'all' stamp: 'sw 1/31/98 00:42'!
updateLiteralLabel
    self computeOperatorOrExpression.
    super updateLiteralLabel! !
LookupKey subclass: #Association
    instanceVariableNames: 'value '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Support'!
!Association commentStamp: 'di 5/22/1998 16:32' prior: 0!
Association comment:
'I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.'!


!Association methodsFor: 'accessing'!
key: aKey value: anObject
    "Store the arguments as the variables of the receiver."

    key _ aKey.
    value _ anObject! !

!Association methodsFor: 'accessing'!
value
    "Answer the value of the receiver."

    ^value! !

!Association methodsFor: 'accessing'!
value: anObject
    "Store the argument, anObject, as the value of the receiver."

    value _ anObject! !


!Association methodsFor: 'printing'!
printOn: aStream

    super printOn: aStream.
    aStream nextPutAll: '->'.
    value printOn: aStream! !

!Association methodsFor: 'printing'!
storeOn: aStream
    "Store in the format (key->value)"
    aStream nextPut: $(.
    key storeOn: aStream.
    aStream nextPutAll: '->'.
    value storeOn: aStream.
    aStream nextPut: $)! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Association class
    instanceVariableNames: ''!

!Association class methodsFor: 'instance creation'!
key: newKey value: newValue
    "Answer an instance of me with the arguments as the key and value of
    the association."

    ^(super key: newKey) value: newValue! !
EllipseMorph subclass: #AtomMorph
    instanceVariableNames: 'velocity '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Demo'!

!AtomMorph methodsFor: 'all'!
bounceIn: aRect
    | p vx vy px py |
    p _ self position.
    vx _ velocity x.  vy _ velocity y.
    px _ p x + vx.  py _ p y + vy.
    px > aRect right ifTrue: [
        px _ aRect right - (px - aRect right).
        vx _ velocity x negated.
    ].
    py > aRect bottom ifTrue: [
        py _  aRect bottom - (py - aRect bottom).
        vy _ velocity y negated.
    ].
    px < aRect left ifTrue: [
        px _ aRect left - (px - aRect left).
        vx _ velocity x negated.
    ].
    py < aRect top ifTrue: [
        py _  aRect top - (py - aRect top).
        vy _ velocity y negated.
    ].
    self position: px @ py.
    self velocity: vx @ vy.
! !

!AtomMorph methodsFor: 'all'!
drawOn: aCanvas
    "Note: Set 'drawAsRect' to true to make the atoms draw faster. When testing the speed of other aspects of Morphic, such as its damage handling efficiency for large numbers of atoms, it is useful to make drawing faster."

    | drawAsRect |
    drawAsRect _ false.  "rectangles are faster to draw"
    drawAsRect
        ifTrue: [aCanvas fillRectangle: self bounds color: color]
        ifFalse: [super drawOn: aCanvas].! !

!AtomMorph methodsFor: 'all'!
infected

    ^ color = Color red! !

!AtomMorph methodsFor: 'all'!
infected: aBoolean

    aBoolean
        ifTrue: [self color: Color red]
        ifFalse: [self color: Color blue].! !

!AtomMorph methodsFor: 'all'!
initialize
    "Make a new atom with a random position and velocity."

    super initialize.
    self extent: 8@7.
    self color: Color blue.
    self borderWidth: 0.
    self randomPositionIn: (0@0 corner: 300@300) maxVelocity: 10.
! !

!AtomMorph methodsFor: 'all'!
randomPositionIn: aRectangle maxVelocity: maxVelocity
    "Give this atom a random position and velocity."

    | origin extent |
    origin _ aRectangle origin.
    extent _ aRectangle extent - self bounds extent.
    self position:
        (origin x + extent x atRandom) @
        (origin y + extent y atRandom).
    velocity _
        (maxVelocity - (2 * maxVelocity) atRandom) @
        (maxVelocity - (2 * maxVelocity) atRandom).
! !

!AtomMorph methodsFor: 'all'!
velocity

    ^ velocity! !

!AtomMorph methodsFor: 'all'!
velocity: newVelocity

    velocity _ newVelocity.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AtomMorph class
    instanceVariableNames: ''!

!AtomMorph class methodsFor: 'all' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
    "Not to be instantiated from the menu"
    ^ false! !
EmbeddedServerAction subclass: #AuthorizedServerAction
    instanceVariableNames: 'authorizer '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!AuthorizedServerAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
An EmbeddedServerAction that also has an Authorizer to verify username and password.!


!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'!
authorizer
    ^authorizer! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 11:20'!
authorizer: anAuthorizer
    authorizer _ anAuthorizer
! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'mjg 11/17/97 13:09'!
checkAuthorization: request
    ^authorizer user: request userID.
! !

!AuthorizedServerAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:46'!
mapName: nameString password: pwdString to: aPerson
    "Insert/remove the username:password combination into/from the users Dictionary.  *** Use this method to add or delete users!!  If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! ***   We use encoding per RFC1421."

    authorizer mapName: nameString password: pwdString to: aPerson.
    self authorizer: authorizer.    "force it to be written to the disk"
        "*** Authorizer not saved to disk yet for this class ***"! !
SwikiAction subclass: #AuthorizedSwikiAction
    instanceVariableNames: 'authorizer '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!AuthorizedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
A Server with a login name and password for the entire Swiki area.  Can be multiple users each with a different password.  Each sees and can modify the whole Swiki area.

To restart an existing Authorized Swiki:

    AuthorizedSwikiAction new restore: 'SWSecure'.

The front page URL is:  http://serverMachine:80/SWSecure.1

To make a completely new one:
    | a s |
    a := Authorizer new.
    a realm: 'SwikiArea'.
    a mapName: 'viki' password: 'hard2guess' to: 'viki'.
    AuthorizedSwikiAction setUp: 'SWSecure'.
    s := AuthorizedSwikiAction new restore: 'SWSecure'.
    s authorizer: a.
!


!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:57'!
authorizer
    ^authorizer! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 07:46'!
authorizer: anAuthorizer
    "Smash all old name/password pairs with this new set.  Overwrites the file on the disk"

    | fName refStream |
    authorizer _ anAuthorizer.
    fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator),
                'authorizer'.
    refStream _ SmartRefStream fileNamed: fName.
    refStream nextPut: authorizer; close.
! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 16:58'!
checkAuthorization: request
    ^authorizer user: request userID.
! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/21/1998 16:30'!
mapName: nameString password: pwdString to: aPerson
    "Insert/remove the username:password combination into/from the users Dictionary.  *** Use this method to add or delete users!!  If you ask for the authorizer and talk to it, the change will not be recorded on the disk!! ***   We use encoding per RFC1421."

    authorizer mapName: nameString password: pwdString to: aPerson.
    self authorizer: authorizer.    "force it to be written to the disk"! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'rp 4/29/98 17:02'!
process: request
    self checkAuthorization: request.
    ^(super process: request).! !

!AuthorizedSwikiAction methodsFor: 'URL processing' stamp: 'tk 5/22/1998 10:21'!
restore: nameOfSwiki
    "Read all files in the directory 'nameOfSwiki'.  Reconstruct the url map."

    | fName |
    super restore: nameOfSwiki.
    fName _ ServerAction serverDirectory, name, (ServerAction pathSeparator),
                'authorizer'.
    authorizer _ (FileStream oldFileNamed: fName) fileInObjectAndCode.
! !
Object subclass: #Authorizer
    instanceVariableNames: 'users realm '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!Authorizer commentStamp: 'di 5/22/1998 16:32' prior: 0!
The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method.
!


!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm
    ^realm! !

!Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'!
realm: aString
    realm := aString
! !


!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 13:01'!
encode: nameString password: pwdString
    "Encode per RFC1421 of the username:password combination."

    | clear code clearSize idx map |
    clear := (nameString, ':', pwdString) asByteArray.
    clearSize := clear size.
    [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ].
    idx := 1.
    map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'.
    code := WriteStream on: ''.
    [ idx < clear size ] whileTrue: [ code
        nextPut: (map at: (clear at: idx) // 4 + 1);
        nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1);
           nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1);
           nextPut: (map at: (clear at: idx + 2) \\ 64 + 1).
        idx := idx + 3 ].
    code := code contents.
    idx := code size.
    clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1].
    ^code! !

!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'!
mapFrom: aKey to: aPerson
    "Establish a mapping from a RFC 1421 key to a user."

    users isNil ifTrue: [ users := Dictionary new ].
    aPerson
     isNil ifTrue: [ users removeKey: aKey ]
     ifFalse: [
        users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: [].
        users at: aKey put: aPerson ]
! !

!Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'!
mapName: nameString password: pwdString to: aPerson
    "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap.  DO NOT call this directly, use mapName:password:to: in your ServerAction class.  Only it knows how to record the change on the disk!!"

    self mapFrom: (self encode: nameString password: pwdString) to: aPerson
! !

!Authorizer methodsFor: 'authentication' stamp: 'mjg 11/17/97 13:07'!
user: userId
    "Return the requesting user."
    ^users at: userId ifAbsent: [ self error: (PWS unauthorizedFor: realm) ]! !
Morph subclass: #BackgroundMorph
    instanceVariableNames: 'image offset delta running '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Widgets'!
!BackgroundMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BackgroundMorph comment:
'This morph incorporates tiling and regular motion with the intent of supporting, eg, panning of endless (toroidal) backgrounds.

The idea is that embedded morphs get displayed at a moving offset relative to my position.  Moreover this display is tiled according to the bounding box of the submorphs (subBounds), as much as necesary to fill the rest of my bounds.'!


!BackgroundMorph methodsFor: 'all' stamp: 'di 11/4/97 09:01'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    running
        ifTrue: [aCustomMenu add: 'stop' action: #stopRunning]
        ifFalse: [aCustomMenu add: 'start' action: #startRunning].
! !

!BackgroundMorph methodsFor: 'all'!
drawOn: aCanvas
    "The tiling is solely determined by bounds, subBounds and offset.
    The extent of display is determined by bounds and the clipRect of the canvas."
    | start tileCanvas d subBnds |
    submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
    subBnds _ self subBounds.
    running ifFalse:
        [super drawOn: aCanvas.
        ^ aCanvas fillRectangle: subBnds color: Color lightBlue].
    start _ subBnds topLeft + offset - bounds topLeft - (1@1) \\ subBnds extent - subBnds extent + (1@1).
    d _ subBnds topLeft - bounds topLeft.
"Sensor redButtonPressed ifTrue: [self halt]."
    start x to: bounds width - 1 by: subBnds width do:
        [:x |
        start y to: bounds height - 1 by: subBnds height do:
            [:y | tileCanvas _ aCanvas copyOffset: (x@y) - d clipRect: bounds.
            submorphs reverseDo: [:m | m fullDrawOn: tileCanvas]]]! !

!BackgroundMorph methodsFor: 'all'!
fullBounds
    ^ self bounds! !

!BackgroundMorph methodsFor: 'all'!
fullDrawOn: aCanvas

    running ifFalse: [^ super fullDrawOn: (aCanvas copyClipRect: (bounds translateBy: aCanvas origin))].
    (aCanvas isVisible: bounds) ifTrue: [self drawOn: aCanvas].
! !

!BackgroundMorph methodsFor: 'all'!
initialize
    super initialize.
    offset _ 0@0.
    delta _ 1@0.
    running _ true! !

!BackgroundMorph methodsFor: 'all'!
layoutChanged
    "Do nothing, since I clip my submorphs"! !

!BackgroundMorph methodsFor: 'all'!
rootForGrabOf: aMorph
    "Be sticky."

    ^ nil
! !

!BackgroundMorph methodsFor: 'all'!
slideBy: inc
    submorphs isEmpty ifTrue: [^ self].
    offset _ offset + inc \\ self subBounds extent.
    self changed! !

!BackgroundMorph methodsFor: 'all'!
startRunning
    running _ true.
    self changed! !

!BackgroundMorph methodsFor: 'all'!
step
    "Answer the desired time between steps in milliseconds."
    running ifTrue: [self slideBy: delta]! !

!BackgroundMorph methodsFor: 'all'!
stepTime
    "Answer the desired time between steps in milliseconds."

    ^ 20! !

!BackgroundMorph methodsFor: 'all'!
stopRunning
    running _ false.
    self changed! !

!BackgroundMorph methodsFor: 'all'!
subBounds
    "calculate the submorph bounds"
    | subBounds |
    subBounds _ nil.
    self submorphsDo:
        [:m | subBounds == nil
            ifTrue: [subBounds _ m fullBounds]
            ifFalse: [subBounds _ subBounds merge: m fullBounds]].
    ^ subBounds! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BackgroundMorph class
    instanceVariableNames: ''!

!BackgroundMorph class methodsFor: 'all'!
test
    ^ self new image: Form fromUser! !
Collection subclass: #Bag
    instanceVariableNames: 'contents '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Unordered'!
!Bag commentStamp: 'di 5/22/1998 16:32' prior: 0!
Bag comment:
'I represent an unordered collection of possibly duplicate elements.

I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.'!


!Bag methodsFor: 'accessing'!
at: index

    self errorNotKeyed! !

!Bag methodsFor: 'accessing'!
at: index put: anObject

    self errorNotKeyed! !

!Bag methodsFor: 'accessing' stamp: 'di 9/11/97 16:14'!
cumulativeCounts
    "Answer with a collection of cumulative percents covered by elements so far."
    | s n |
    s _ self size // 100.0. n _ 0.
    ^ self sortedCounts asArray collect:
        [:a | n _ n + a key. (n // s roundTo: 0.1) -> a value]! !

!Bag methodsFor: 'accessing'!
size

    | tally |
    tally _ 0.
    contents do: [:each | tally _ tally + each].
    ^tally! !

!Bag methodsFor: 'accessing'!
sortedCounts
    "Answer with a collection of counts with elements, sorted by decreasing
    count."

    | counts |
    counts _ SortedCollection sortBlock: [:x :y | x >= y].
    contents associationsDo:
        [:assn |
        counts add: (Association key: assn value value: assn key)].
    ^counts! !

!Bag methodsFor: 'accessing'!
sortedElements
    "Answer with a collection of elements with counts, sorted by element."

    | elements |
    elements _ SortedCollection new.
    contents associationsDo: [:assn | elements add: assn].
    ^elements! !


!Bag methodsFor: 'testing'!
includes: anObject
    "Refer to the comment in Collection|includes:."

    ^contents includesKey: anObject! !

!Bag methodsFor: 'testing'!
occurrencesOf: anObject
    "Refer to the comment in Collection|occurrencesOf:."

    (self includes: anObject)
        ifTrue: [^contents at: anObject]
        ifFalse: [^0]! !


!Bag methodsFor: 'adding'!
add: newObject
    "Refer to the comment in Collection|add:."

    ^self add: newObject withOccurrences: 1! !

!Bag methodsFor: 'adding'!
add: newObject withOccurrences: anInteger
    "Add the element newObject to the receiver. Do so as though the element
    were added anInteger number of times. Answer newObject."

    (self includes: newObject)
        ifTrue: [contents at: newObject put: anInteger + (contents at: newObject)]
        ifFalse: [contents at: newObject put: anInteger].
    ^newObject! !


!Bag methodsFor: 'removing'!
remove: oldObject ifAbsent: exceptionBlock
    "Refer to the comment in Collection|remove:ifAbsent:."

    | count |
    (self includes: oldObject)
        ifTrue: [(count _ contents at: oldObject) = 1
                ifTrue: [contents removeKey: oldObject]
                ifFalse: [contents at: oldObject put: count - 1]]
        ifFalse: [^exceptionBlock value].
    ^oldObject! !


!Bag methodsFor: 'enumerating' stamp: 'SqR 11/4/97 19:58'!
asSet
    "Answer a set with the elements of the receiver"

     ^contents keys! !

!Bag methodsFor: 'enumerating'!
do: aBlock
    "Refer to the comment in Collection|do:."

    contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !


!Bag methodsFor: 'private'!
setDictionary

    contents _ Dictionary new! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bag class
    instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation'!
new

    ^super new setDictionary! !

!Bag class methodsFor: 'instance creation'!
newFrom: aCollection
    "Answer an instance of me containing the same elements as aCollection."

    | newCollection |
    newCollection _ self new.
    newCollection addAll: aCollection.
    ^newCollection

"    Bag newFrom: {1. 2. 3}
    {1. 2. 3} as: Bag
"! !
CurveMorph subclass: #BalloonMorph
    instanceVariableNames: 'target offsetFromTarget '
    classVariableNames: 'BalloonFont '
    poolDictionaries: ''
    category: 'Morphic-Widgets'!
!BalloonMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BalloonMorph comment:
'A balloon with text used for the display of explanatory information.

Balloon help is integrated into Morphic as follows:
If a Morph has the property #balloonText, then it will respond to #showBalloon by adding a text balloon to the world, and to #deleteBalloon by removing the balloon.

Moreover, if mouseOverEnabled is true (see class msg), then the Hand will arrange to cause display of the balloon after the mouse has lingered over the morph for a while, and removal of the balloon when the mouse leaves the bounds of that morph.  In any case, the Hand will attempt to remove any such balloons before handling mouseDown events, or displaying other balloons.'!


!BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:26'!
setTarget: aMorph
    target _ aMorph.
    offsetFromTarget _ self position - target position! !

!BalloonMorph methodsFor: 'all' stamp: 'di 9/17/97 19:27'!
step
    self position: target position + offsetFromTarget! !

!BalloonMorph methodsFor: 'all' stamp: 'di 9/18/97 10:10'!
stepTime
    ^ 0  "every cycle"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BalloonMorph class
    instanceVariableNames: ''!

!BalloonMorph class methodsFor: 'all' stamp: 'di 10/20/97 20:10'!
chooseBalloonFont
    | sizes reply |
    sizes _ #(9 10 12 14).
    reply _ (SelectionMenu labelList: (sizes collect: [:s | s printString]) selections:  sizes) startUp.
    reply ifNotNil:
        [BalloonFont _ (TextStyle named: #ComicPlain) fontAt: (sizes indexOf: reply)]! !

!BalloonMorph class methodsFor: 'all' stamp: 'jm 5/20/1998 20:16'!
string: str for: morph corner: cornerName
    "Make up and return a balloon for morph.  Find the quadrant that
clips the text the least, using cornerName as a tie-breaker.  tk 9/12/97"

    | txt tm corners p1 p2 vertices c r maxArea aa verts mp dir mbc
 pref rectCorner morphPoint |
    BalloonFont
        ifNil: [txt _ str]
        ifNotNil: [txt _ Text string: str attribute: (TextFontReference toFont: BalloonFont)].
    tm _ (TextMorph new contents: txt) centered.

    "Construct vertices for a balloon below and to left of anchor"
    corners _ tm bounds corners atAll: #(1 4 3 2).
    p1 _ (corners at: 1) + ((0 - tm width//3)@0).
    p2 _ (corners at: 1) + ((0 - tm width//6)@(tm height//2)).
    vertices _ (Array with: p1 with: p2) , corners.
    r _ p1 rect: (corners at: 3).
    corners _ #(bottomRight bottomLeft topLeft topRight).
    pref _ corners indexOf: cornerName.
    c _ tm center.
    maxArea _ 0.
    (0 to: 3) do:
        [:i | "Try four rel locations of the balloon for greatest unclipped area"
        rectCorner _ corners atWrap: i+pref+2.
        morphPoint _ (#(bottomRight bottomLeft) includes: rectCorner)
                        ifTrue: [#topCenter] ifFalse: [#bottomCenter].
        aa _ ((r align: (r perform: rectCorner)
                with: (mbc _ morph fullBoundsInWorld perform: morphPoint))
            intersect: (0@0 extent: morph world viewBox extent)) area.
        aa > maxArea ifTrue: [verts _ vertices.
                            maxArea _ aa.
                            mp _ mbc].
        dir _ (i+pref) odd ifTrue: [#horizontal] ifFalse: [#vertical].
        vertices _ vertices collect: [:p | p flipBy: dir centerAt: c]].
    ^ self new color: (Color r: 1.0 g: 1.0 b: 0.6);
            setBorderWidth: 1 borderColor: Color black;
            setVertices: verts;
            addMorph: tm;
            align: verts first with: mp;
            setTarget: morph! !
Object subclass: #Base64MimeConverter
    instanceVariableNames: 'dataStream mimeStream data '
    classVariableNames: 'FromCharTable ToCharTable '
    poolDictionaries: ''
    category: 'Collections-Streams'!
!Base64MimeConverter commentStamp: 'di 5/22/1998 16:32' prior: 0!
This class encodes and decodes data in Base64 format.  This is MIME encoding.  We translate a whole stream at once, taking a Stream as input and giving one as output.  Returns a whole stream for the caller to use.
           0 A            17 R            34 i            51 z
           1 B            18 S            35 j            52 0
           2 C            19 T            36 k            53 1
           3 D            20 U            37 l            54 2
           4 E            21 V            38 m            55 3
           5 F            22 W            39 n            56 4
           6 G            23 X            40 o            57 5
           7 H            24 Y            41 p            58 6
           8 I            25 Z            42 q            59 7
           9 J            26 a            43 r            60 8
          10 K            27 b            44 s            61 9
          11 L            28 c            45 t            62 +
          12 M            29 d            46 u            63 /
          13 N            30 e            47 v
          14 O            31 f            48 w         (pad) =
          15 P            32 g            49 x
          16 Q            33 h            50 y
Outbound: bytes are broken into 6 bit chunks, and the 0-63 value is converted to a character.  3 data bytes go into 4 characters.
Inbound: Characters are translated in to 0-63 values and shifted into 8 bit bytes.

(See: N. Borenstein, Bellcore, N. Freed, Innosoft, Network Working Group, Request for Comments: RFC 1521, September 1993, MIME (Multipurpose Internet Mail Extensions) Part One: Mechanisms for Specifying and Describing the Format of Internet Message Bodies. Sec 6.2)

By Ted Kaehler, based on Tim Olson's Base64Filter.!


!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:55'!
dataStream
    ^dataStream! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
dataStream: anObject
    dataStream _ anObject! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:53'!
mimeStream
    ^mimeStream! !

!Base64MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'!
mimeStream: anObject
    mimeStream _ anObject! !


!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:34'!
mimeDecode
    "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full byte stream of characters.  Reutrn a whole stream for the user to read."

    | nibA nibB nibC nibD |
    [mimeStream atEnd] whileFalse: [
        (nibA _ self nextValue) ifNil: [^ dataStream].
        (nibB _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)) asCharacter.
        nibB _ nibB bitAnd: 16rF.
        (nibC _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)) asCharacter.
        nibC _ nibC bitAnd: 16r3.
        (nibD _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibC bitShift: 6) + nibD) asCharacter.
        ].
    ^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:39'!
mimeDecodeToByteArray
    "Convert a stream in base 64 with only a-z,A-Z,0-9,+,/ to a full ByteArray of 0-255 values.  Reutrn a whole stream for the user to read."

    | nibA nibB nibC nibD |
    [mimeStream atEnd] whileFalse: [
        (nibA _ self nextValue) ifNil: [^ dataStream].
        (nibB _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibA bitShift: 2) + (nibB bitShift: -4)).
        nibB _ nibB bitAnd: 16rF.
        (nibC _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibB bitShift: 4) + (nibC bitShift: -2)).
        nibC _ nibC bitAnd: 16r3.
        (nibD _ self nextValue) ifNil: [^ dataStream].
        dataStream nextPut: ((nibC bitShift: 6) + nibD).
        ].
    ^ dataStream! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 12:57'!
mimeEncode
    "Convert from data to 6 bit characters."

    | phase1 phase2 raw nib |
    phase1 _ phase2 _ false.
    [dataStream atEnd] whileFalse: [
        data _ raw _ dataStream next asInteger.
        nib _ (data bitAnd: 16rFC) bitShift: -2.
        mimeStream nextPut: (ToCharTable at: nib+1).
        (raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true].
        data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger.
        nib _ (data bitAnd: 16r3F0) bitShift: -4.
        mimeStream nextPut: (ToCharTable at: nib+1).
        (raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true].
        data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger).
        nib _ (data bitAnd: 16rFC0) bitShift: -6.
        mimeStream nextPut: (ToCharTable at: nib+1).
        nib _ (data bitAnd: 16r3F).
        mimeStream nextPut: (ToCharTable at: nib+1)].
    phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=.
            ^ mimeStream].
    phase2 ifTrue: [mimeStream skip: -1; nextPut: $=.
            ^ mimeStream].

! !

!Base64MimeConverter methodsFor: 'conversion' stamp: 'tk 12/9/97 13:21'!
nextValue
    "The next six bits of data char from the mimeStream, or nil.  Skip all other chars"
    | raw num |
    [raw _ mimeStream next.
    raw ifNil: [^ nil].    "end of stream"
    raw == $= ifTrue: [^ nil].
    num _ FromCharTable at: raw asciiValue + 1.
    num ifNotNil: [^ num].
    "else ignore space, return, tab, ..."
    true] whileTrue.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Base64MimeConverter class
    instanceVariableNames: ''!

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 14:29'!
example
    "Base64MimeConverter example"

| ss bb |
ss _ ReadWriteStream on: (String new: 10).
ss nextPutAll: 'Hi There!!'.
bb _ Base64MimeConverter mimeEncode: ss.
    "bb contents  'SGkgVGhlcmUh'"
^ (Base64MimeConverter mimeDecodeToChars: bb) contents

! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:53'!
initialize

    FromCharTable _ Array new: 256.    "nils"
    ToCharTable _ Array new: 64.
    ($A asciiValue to: $Z asciiValue) doWithIndex: [:val :ind |
        FromCharTable at: val+1 put: ind-1.
        ToCharTable at: ind put: val asCharacter].
    ($a asciiValue to: $z asciiValue) doWithIndex: [:val :ind |
        FromCharTable at: val+1 put: ind+25.
        ToCharTable at: ind+26 put: val asCharacter].
    ($0 asciiValue to: $9 asciiValue) doWithIndex: [:val :ind |
        FromCharTable at: val+1 put: ind+25+26.
        ToCharTable at: ind+26+26 put: val asCharacter].
    FromCharTable at: $+ asciiValue + 1 put: 62.
    ToCharTable at: 63 put: $+.
    FromCharTable at: $/ asciiValue + 1 put: 63.
    ToCharTable at: 64 put: $/.
    ! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/12/97 11:41'!
mimeDecodeToBytes: aStream
    "Return a RWBinaryOrTextStream of the original ByteArray.  aStream has only 65 innocuous character values.  aStream is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

    | me |
    aStream position: 0.
    me _ self new mimeStream: aStream.
    me dataStream: (RWBinaryOrTextStream on: (ByteArray new: aStream size * 3 // 4)).
    me mimeDecodeToByteArray.
    me dataStream position: 0.
    ^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 13:01'!
mimeDecodeToChars: aStream
    "Return a ReadWriteStream of the original String.  aStream has only 65 innocuous character values.  It is not binary.  (See class comment). 4 bytes in aStream goes to 3 bytes in output."

    | me |
    aStream position: 0.
    me _ self new mimeStream: aStream.
    me dataStream: (ReadWriteStream on: (String new: aStream size * 3 // 4)).
    me mimeDecode.
    me dataStream position: 0.
    ^ me dataStream! !

!Base64MimeConverter class methodsFor: 'as yet unclassified' stamp: 'tk 12/9/97 12:28'!
mimeEncode: aStream
    "Return a ReadWriteStream of characters.  The data of aStream is encoded as 65 innocuous characters.  (See class comment). 3 bytes in aStream goes to 4 bytes in output."

    | me |
    aStream position: 0.
    me _ self new dataStream: aStream.
    me mimeStream: (ReadWriteStream on: (String new: aStream size + 20 * 4 // 3)).
    me mimeEncode.
    me mimeStream position: 0.
    ^ me mimeStream! !
Object subclass: #Behavior
    instanceVariableNames: 'superclass methodDict format subclasses '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Classes'!
!Behavior commentStamp: 'di 5/22/1998 16:32' prior: 0!
Behavior comment:
'My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).'!


!Behavior methodsFor: 'initialize-release'!
obsolete
    "Invalidate and recycle local messages. Remove the receiver from its
    superclass' subclass list."

    methodDict _ MethodDictionary new.
    superclass == nil ifFalse: [superclass removeSubclass: self]! !


!Behavior methodsFor: 'accessing'!
compilerClass
    "Answer a compiler class appropriate for source methods of this class."

    ^Compiler! !

!Behavior methodsFor: 'accessing' stamp: 'sw 3/10/97'!
confirmRemovalOf: aSelector
    "Determine if it is okay to remove the given selector.  Answer 1 if it should be removed, 2 if it should be removed followed by a senders browse, and 3 if it should not be removed.
    9/18/96 sw: made the wording more delicate
    : bug fix -- auto select string needs to be first keyword only"

    | count aMenu answer caption allCalls |
    (count _ (allCalls _ Smalltalk allCallsOn: aSelector) size) > 0
        ifTrue:
            [aMenu _ PopUpMenu labels: 'Remove it
Remove, then browse senders
Don''t remove, but show me those senders
Forget it -- do nothing -- sorry I asked'.

            caption _ 'This message has ', count printString, ' sender'.
            count > 1 ifTrue:
                [caption _ caption copyWith: $s].
            answer _ aMenu startUpWithCaption: caption.
            answer == 3 ifTrue:
                [Smalltalk browseMessageList: allCalls
                    name: 'Senders of ', aSelector
                    autoSelect: aSelector keywords first].
            answer == 0 ifTrue: [answer _ 3].  "If user didn't answer, treat it as cancel"
            ^ answer min: 3]
        ifFalse:
            [^ 1]
    ! !

!Behavior methodsFor: 'accessing'!
decompilerClass
    "Answer a decompiler class appropriate for compiled methods of this class."

    ^Decompiler! !

!Behavior methodsFor: 'accessing'!
evaluatorClass
    "Answer an evaluator class appropriate for evaluating expressions in the
    context of this class."

    ^Compiler! !

!Behavior methodsFor: 'accessing'!
format
    "Answer an Integer that encodes the kinds and numbers of variables of
    instances of the receiver."

    ^format! !

!Behavior methodsFor: 'accessing'!
parserClass
    "Answer a parser class to use for parsing method headers."

    ^self compilerClass parserClass! !

!Behavior methodsFor: 'accessing'!
sourceCodeTemplate
    "Answer an expression to be edited and evaluated in order to define
    methods in this class."

    ^'message selector and argument names
    "comment stating purpose of message"

    | temporary variable names |
    statements'! !

!Behavior methodsFor: 'accessing'!
subclassDefinerClass
    "Answer an evaluator class appropriate for evaluating definitions of new
    subclasses of this class."

    ^Compiler! !


!Behavior methodsFor: 'testing'!
instSize
    "Answer the number of named instance variables
    (as opposed to indexed variables) of the receiver."

    self flag: #instSizeChange.  "Smalltalk browseAllCallsOn: #instSizeChange"
"
    NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
    When we revise the image format, it should become...
    ^ ((format bitShift: -1) bitAnd: 16rFF) - 1
    Note also that every other method in this category will require
    2 bits more of right shift after the change.
"
    ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! !

!Behavior methodsFor: 'testing'!
instSpec
    ^ (format bitShift: -7) bitAnd: 16rF! !

!Behavior methodsFor: 'testing'!
isBits
    "Answer whether the receiver contains just bits (not pointers)."

    ^ self instSpec >= 6! !

!Behavior methodsFor: 'testing'!
isBytes
    "Answer whether the receiver has 8-bit instance variables."

    ^ self instSpec >= 8! !

!Behavior methodsFor: 'testing'!
isFixed
    "Answer whether the receiver does not have a variable (indexable) part."

    ^self isVariable not! !

!Behavior methodsFor: 'testing'!
isPointers
    "Answer whether the receiver contains just pointers (not bits)."

    ^self isBits not! !

!Behavior methodsFor: 'testing'!
isVariable
    "Answer whether the receiver has indexable variables."

    ^ self instSpec >= 2! !

!Behavior methodsFor: 'testing'!
isWords
    "Answer whether the receiver has 16-bit instance variables."

    ^self isBytes not! !


!Behavior methodsFor: 'copying'!
copy
    "Answer a copy of the receiver without a list of subclasses."

    | myCopy savedSubclasses |
    savedSubclasses _ subclasses.
    subclasses _ nil.
    myCopy _ self shallowCopy.
    subclasses _ savedSubclasses.
    ^myCopy methodDictionary: methodDict copy! !


!Behavior methodsFor: 'printing' stamp: 'sw 2/16/98 01:30'!
defaultNameStemForInstances
    "Answer a basis for names of default instances of the receiver"
    ^ self name! !

!Behavior methodsFor: 'printing'!
literalScannedAs: scannedLiteral notifying: requestor
    "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
    If scannedLiteral is not an association, answer it.
    Else, if it is of the form:
        nil->#NameOfMetaclass
    answer nil->theMetaclass, if any has that name, else report an error.
    Else, if it is of the form:
        #NameOfGlobalVariable->anythiEng
    answer the global, class, or pool association with that nameE, if any, else
    add it to Undeclared a answer the new Association."

    | key value |
    (scannedLiteral isMemberOf: Association)
        ifFalse: [^ scannedLiteral].
    key _ scannedLiteral key.
    value _ scannedLiteral value.
    key isNil
        ifTrue: "###<metaclass soleInstance name>"
            [self scopeHas: value ifTrue:
                [:assoc |
                 (assoc value isKindOf: Behavior)
                    ifTrue: [^ nil->assoc value class]].
             requestor notify: 'No such metaclass'.
             ^false].
    (key isMemberOf: Symbol)
        ifTrue: "##<global var name>"
            [(self scopeHas: key ifTrue: [:assoc | ^assoc])
                ifFalse:
                    [Undeclared at: key put: nil.
                     ^ Undeclared associationAt: key]].
    requestor notify: '## must be followed by a non-local variable name'.
    ^false

"    Form literalScannedAs: 14 notifying: nil 14
    Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
    Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
    Form literalScannedAs: ##Form notifying: nil   Form->Form
    Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"! !

!Behavior methodsFor: 'printing'!
printHierarchy
    "Answer a description containing the names and instance variable names
    of all of the subclasses and superclasses of the receiver."

    | aStream index |
    index _ 0.
    aStream _ WriteStream on: (String new: 16).
    self allSuperclasses reverseDo:
        [:aClass |
        aStream crtab: index.
        index _ index + 1.
        aStream nextPutAll: aClass name.
        aStream space.
        aStream print: aClass instVarNames].
    aStream cr.
    self printSubclassesOn: aStream level: index.
    ^aStream contents! !

!Behavior methodsFor: 'printing'!
printOn: aStream
    "Refer to the comment in Object|printOn:."

    aStream nextPutAll: 'a descendent of '.
    superclass printOn: aStream! !

!Behavior methodsFor: 'printing'!
storeLiteral: aCodeLiteral on: aStream
    "Store aCodeLiteral on aStream, changing an Association to ##GlobalName
     or ###MetaclassSoleInstanceName format if appropriate"
    | key value |
    (aCodeLiteral isMemberOf: Association)
        ifFalse:
            [aCodeLiteral storeOn: aStream.
             ^self].
    key _ aCodeLiteral key.
    (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass])
        ifTrue:
            [aStream nextPutAll: '###'; nextPutAll: value soleInstance name.
             ^self].
    ((key isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]])
        ifTrue:
            [aStream nextPutAll: '##'; nextPutAll: key.
             ^self].
    aCodeLiteral storeOn: aStream! !


!Behavior methodsFor: 'creating class hierarchy'!
addSubclass: aSubclass
    "Make the argument, aSubclass, be one of the subclasses of the receiver.
    Create an error notification if the argument's superclass is not the
    receiver."

    aSubclass superclass ~~ self
        ifTrue: [self error: aSubclass name , ' is not my subclass']
        ifFalse: [subclasses == nil
                    ifTrue:    [subclasses _ Set with: aSubclass]
                    ifFalse:    [subclasses add: aSubclass]]! !

!Behavior methodsFor: 'creating class hierarchy' stamp: 'tk 3/19/98 10:16'!
removeSubclass: aSubclass
    "If the argument, aSubclass, is one of the receiver's subclasses, remove it."

    subclasses == nil ifFalse:
        [subclasses remove: aSubclass ifAbsent: [].
        subclasses isEmpty ifTrue: [subclasses _ nil]].
    Object flushCache.
! !

!Behavior methodsFor: 'creating class hierarchy'!
superclass: aClass
    "Change the receiver's superclass to be aClass."

    (aClass == nil or: [aClass isKindOf: Behavior])
        ifTrue: [superclass _ aClass]
        ifFalse: [self error: 'superclass must be a class-describing object']! !


!Behavior methodsFor: 'creating method dictionary' stamp: 'di 12/26/97 11:04'!
addSelector: selector withMethod: compiledMethod
    "Add the message selector with the corresponding compiled method to the
    receiver's method dictionary."

    methodDict at: selector put: compiledMethod.
    selector flushCache! !

!Behavior methodsFor: 'creating method dictionary'!
compile: code
    "Compile the argument, code, as source code in the context of the
    receiver. Create an error notification if the code can not be compiled.
    The argument is either a string or an object that converts to a string or a
    PositionableStream on an object that converts to a string."

    ^self compile: code notifying: nil! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'tk 12/6/97 21:33'!
compile: code notifying: requestor
    "Compile the argument, code, as source code in the context of the
    receiver and insEtall the result in the receiver's method dictionary. The
    second argument, requestor, is to be notified if an error occurs. The
    argument code is either a string or an object that converts to a string or
    a PositionableStream. This method also saves the source code."
    | method selector methodNode |
    method _ self
        compile: code "a Text"
        notifying: requestor
        trailer: #(0 0 0 0)
        ifFail: [^nil]
        elseSetSelectorAndNode:
            [:sel :parseNode | selector _ sel.  methodNode _ parseNode].
    method putSource: code "a Text" fromParseNode: methodNode inFile: 2
            withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr].
    ^selector! !

!Behavior methodsFor: 'creating method dictionary'!
compileAll
    ^ self compileAllFrom: self! !

!Behavior methodsFor: 'creating method dictionary'!
compileAllFrom: oldClass
    "Compile all the methods in the receiver's method dictionary.
    This validates sourceCode and variable references and forces
    all methods to use the current bytecode set"

    self selectorsDo: [:sel | self recompile: sel from: oldClass]! !

!Behavior methodsFor: 'creating method dictionary'!
compress
    "Compact the method dictionary of the receiver."

    methodDict rehash! !

!Behavior methodsFor: 'creating method dictionary'!
decompile: selector
    "Find the compiled code associated with the argument, selector, as a
    message selector in the receiver's method dictionary and decompile it.
    Answer the resulting source code as a string. Create an error notification
    if the selector is not in the receiver's method dictionary."

    ^self decompilerClass new decompile: selector in: self! !

!Behavior methodsFor: 'creating method dictionary'!
defaultSelectorForMethod: aMethod
    "Given a method, invent and answer an appropriate message selector (a
    Symbol), that is, one that will parse with the correct number of
    arguments."

    | aStream |
    aStream _ WriteStream on: (String new: 16).
    aStream nextPutAll: 'DoIt'.
    1 to: aMethod numArgs do: [:i | aStream nextPutAll: 'with:'].
    ^aStream contents asSymbol! !

!Behavior methodsFor: 'creating method dictionary'!
methodDictionary: aDictionary
    "Store the argument, aDictionary, as the method dictionary of the
    receiver."

    methodDict _ aDictionary! !

!Behavior methodsFor: 'creating method dictionary'!
recompile: selector from: oldClass
    "Compile the method associated with selector in the receiver's method dictionary."
    | method trailer methodNode |
    method _ self compiledMethodAt: selector.
    trailer _ (method size - 3 to: method size) collect: [:i | method at: i].
    methodNode _ self compilerClass new
                compile: (oldClass sourceCodeAt: selector)
                in: self
                notifying: nil
                ifFail: [^ self].   "Assume OK after proceed from SyntaxError"
    selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
    self addSelector: selector withMethod: (methodNode generate: trailer).
! !

!Behavior methodsFor: 'creating method dictionary'!
recompileChanges
    "Compile all the methods that are in the changes file.
    This validates sourceCode and variable references and forces
    methods to use the current bytecode set"

    self selectorsDo:
        [:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue:
            [self recompile: sel from: self]]! !

!Behavior methodsFor: 'creating method dictionary' stamp: 'di 12/26/97 11:08'!
removeSelector: selector
    "Assuming that the argument, selector (a Symbol), is a message selector
    in the receiver's method dictionary, remove it. If the selector is not in
    the method dictionary, create an error notification."

    methodDict removeKey: selector.
    selector flushCache! !


!Behavior methodsFor: 'instance creation'!
basicNew
    "Primitive. Answer an instance of the receiver (which is a class) with no
    indexable variables. Fail if the class is indexable. Essential. See Object
    documentation whatIsAPrimitive."

    <primitive: 70>
    self isVariable ifTrue: [ ^ self basicNew: 0 ].
    "space must be low"
    Smalltalk signalLowSpace.
    ^ self basicNew  "retry if user proceeds"
! !

!Behavior methodsFor: 'instance creation'!
basicNew: anInteger
    "Primitive. Answer an instance of the receiver (which is a class) with the
    number of indexable variables specified by the argument, anInteger. Fail
    if the class is not indexable or if the argument is not a positive Integer.
    Essential. See Object documentation whatIsAPrimitive."

    <primitive: 71>
    (anInteger isInteger and: [anInteger >= 0]) ifTrue: [
        "arg okay; space must be low"
        Smalltalk signalLowSpace.
        ^ self basicNew: anInteger  "retry if user proceeds"
    ].
    self primitiveFailed! !

!Behavior methodsFor: 'instance creation'!
new
    "Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable."
    "Essential Primitive. See Object documentation whatIsAPrimitive."

    <primitive: 70>
    self isVariable ifTrue: [^ self basicNew: 0].
    "space must be low"
    Smalltalk signalLowSpace.
    ^ self basicNew  "retry if user proceeds"
! !

!Behavior methodsFor: 'instance creation'!
new: anInteger
    "Primitive. Answer an instance of the receiver (which is a class) with the
    number of indexable variables specified by the argument, anInteger. Fail
    if the class is not indexable or if the argument is not a positive Integer.
    Essential. See Object documentation whatIsAPrimitive."

    <primitive: 71>
    (anInteger isInteger and: [anInteger >= 0]) ifTrue: [
        "arg okay; space must be low"
        Smalltalk signalLowSpace.
        ^ self basicNew: anInteger  "retry if user proceeds"
    ].
    self primitiveFailed! !


!Behavior methodsFor: 'accessing class hierarchy'!
allSubclasses
    "Answer a Set of the receiver's and the receiver's descendent's subclasses."

    | aSet |
    aSet _ Set new.
    aSet addAll: self subclasses.
    self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
    ^aSet! !

!Behavior methodsFor: 'accessing class hierarchy'!
allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level
    "Walk the tree of subclasses, giving the class and its level"
    | subclassNames subclass |
    classAndLevelBlock value: self value: level.
    self == Class ifTrue:  [^ self].  "Don't visit all the metaclasses"
    "Visit subclasses in alphabetical order"
    subclassNames _ SortedCollection new.
    self subclassesDo: [:subC | subclassNames add: subC name].
    subclassNames do:
        [:name | (Smalltalk at: name)
            allSubclassesWithLevelDo: classAndLevelBlock
            startingLevel: level+1]! !

!Behavior methodsFor: 'accessing class hierarchy'!
allSuperclasses
    "Answer an OrderedCollection of the receiver's and the receiver's
    ancestor's superclasses. The first element is the receiver's immediate
    superclass, followed by its superclass; the last element is Object."

    | temp |
    superclass == nil
        ifTrue: [^OrderedCollection new]
        ifFalse: [temp _ superclass allSuperclasses.
                temp addFirst: superclass.
                ^temp]! !

!Behavior methodsFor: 'accessing class hierarchy'!
subclasses
    "Answer a Set containing the receiver's subclasses."

    subclasses == nil
        ifTrue: [^Set new]
        ifFalse: [^subclasses copy]! !

!Behavior methodsFor: 'accessing class hierarchy'!
superclass
    "Answer the receiver's superclass, a Class."

    ^superclass! !

!Behavior methodsFor: 'accessing class hierarchy'!
withAllSubclasses
    "Answer a Set of the receiver, the receiver's descendent's, and the
    receiver's descendent's subclasses."

    | aSet |
    aSet _ Set with: self.
    aSet addAll: self subclasses.
    self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
    ^aSet! !

!Behavior methodsFor: 'accessing class hierarchy'!
withAllSuperclasses
    "Answer an OrderedCollection of the receiver and the receiver's
    superclasses. The first element is the receiver,
    followed by its superclass; the last element is Object."

    | temp |
    temp _ self allSuperclasses.
    temp addFirst: self.
    ^ temp! !


!Behavior methodsFor: 'accessing method dictionary'!
allSelectors
    "Answer a Set of all the message selectors that instances of the receiver
    can understand."

    | temp |
    superclass == nil
        ifTrue: [^self selectors]
        ifFalse: [temp _ superclass allSelectors.
                temp addAll: self selectors.
                ^temp]

    "Point allSelectors"! !

!Behavior methodsFor: 'accessing method dictionary'!
changeRecordsAt: selector
    "Return a list of ChangeRecords for all versions of the method at selector.
    Source code can be retrieved by sending string to any one"
    "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
    ^ (ChangeList new
            scanVersionsOf: (self compiledMethodAt: selector)
            class: self meta: self isMeta
            category: (self whichCategoryIncludesSelector: selector)
            selector: selector)
        changeList! !

!Behavior methodsFor: 'accessing method dictionary'!
compiledMethodAt: selector
    "Answer the compiled method associated with the argument, selector (a
    Symbol), a message selector in the receiver's method dictionary. If the
    selector is not in the dictionary, create an error notification."

    ^methodDict at: selector! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 1/15/98 19:34'!
compiledMethodAt: selector ifAbsent: aBlock
    "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock"

    ^ methodDict at: selector ifAbsent: [aBlock value]! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 1/7/98 10:31'!
compressedSourceCodeAt: selector
    "(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921
    Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450"
    | rawText parse |
    rawText _ (self sourceCodeAt: selector) asString.
    parse _ self compilerClass new parse: rawText in: self notifying: nil.
    ^ rawText compressWithTable:
        ((selector keywords ,
        parse tempNames ,
        self instVarNames ,
        #(self super ifTrue: ifFalse:) ,
        ((0 to: 7) collect:
            [:i | String streamContents:
                [:s | s cr. i timesRepeat: [s tab]]]) ,
        (self compiledMethodAt: selector) literalStrings)
            asSortedCollection: [:a :b | a size > b size])! !

!Behavior methodsFor: 'accessing method dictionary'!
firstCommentAt:  selector
    "Answer a string representing the first comment in the method associated with selector.  Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment.  Not smart enough to bypass quotes in string constants, but ""clever"" enough to map doubled quotes into a single quote.  5/1/96 sw"
    "Behavior firstCommentAt: #firstCommentAt:"

    | sourceString commentStart  pos nextQuotePos |

    sourceString _ self sourceCodeAt: selector.
    sourceString size == 0 ifTrue: [^ ''].
    commentStart _ sourceString findString: '"' startingAt: 1.
    commentStart == 0 ifTrue: [^ ''].
    pos _ commentStart + 1.
    [(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)]
        whileTrue:
            [pos _ nextQuotePos + 2].

    ^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'! !

!Behavior methodsFor: 'accessing method dictionary'!
selectorAtMethod: method setClass: classResultBlock
    "Answer both the message selector associated with the compiled method
    and the class in which that selector is defined."

    | sel |
    sel _ methodDict keyAtValue: method
                ifAbsent:
                    [superclass == nil
                        ifTrue:
                            [classResultBlock value: self.
                            ^self defaultSelectorForMethod: method].
                    sel _ superclass selectorAtMethod: method setClass: classResultBlock.
                    "Set class to be self, rather than that returned from
                    superclass. "
                    sel == (self defaultSelectorForMethod: method) ifTrue: [classResultBlock value: self].
                    ^sel].
    classResultBlock value: self.
    ^sel! !

!Behavior methodsFor: 'accessing method dictionary'!
selectors
    "Answer a Set of all the message selectors specified in the receiver's
    method dictionary."

    ^methodDict keys

    "Point selectors."! !

!Behavior methodsFor: 'accessing method dictionary'!
selectorsDo: selectorBlock
    "Evaluate selectorBlock for all the message selectors in my method dictionary."

    ^methodDict keysDo: selectorBlock! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/13/98 17:34'!
sourceCodeAt: selector

    ^ (methodDict at: selector) getSourceFor: selector in: self! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:09'!
sourceCodeAt: selector ifAbsent: aBlock

    ^ (methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! !

!Behavior methodsFor: 'accessing method dictionary'!
sourceMethodAt: selector
    "Answer the paragraph corresponding to the source code for the
    argument."

    ^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! !

!Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 11/3/97 00:10'!
sourceMethodAt: selector ifAbsent: aBlock
    "Answer the paragraph corresponding to the source code for the
    argument."

    ^ (self sourceCodeAt: selector ifAbsent: [^ aBlock value]) asText makeSelectorBoldIn: self! !


!Behavior methodsFor: 'accessing instances and variables'!
allClassVarNames
    "Answer a Set of the names of the receiver's and the receiver's ancestor's
    class variables."

    ^superclass allClassVarNames! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'jm 5/20/1998 15:53'!
allInstances
    "Answer a collection of all current instances of the receiver."

    | all |
    all _ OrderedCollection new.
    self allInstancesDo: [:x | x == all ifFalse: [all add: x]].
    ^ all asArray
! !

!Behavior methodsFor: 'accessing instances and variables'!
allInstVarNames
    "Answer an Array of the names of the receiver's instance variables. The
    Array ordering is the order in which the variables are stored and
    accessed by the interpreter."

    | vars |
    superclass == nil
        ifTrue: [vars _ self instVarNames copy]    "Guarantee a copy is answered."
        ifFalse: [vars _ superclass allInstVarNames , self instVarNames].
    ^vars! !

!Behavior methodsFor: 'accessing instances and variables'!
allSharedPools
    "Answer a Set of the names of the pools (Dictionaries) that the receiver
    and the receiver's ancestors share."

    ^superclass allSharedPools! !

!Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'!
allSubInstances
    "Answer a list of all current instances of the receiver and all of its subclasses."
    | aCollection |
    aCollection _ OrderedCollection new.
    self allSubInstancesDo:
        [:x | x == aCollection ifFalse: [aCollection add: x]].
    ^ aCollection! !

!Behavior methodsFor: 'accessing instances and variables'!
classVarNames
    "Answer a Set of the receiver's class variable names."

    ^Set new! !

!Behavior methodsFor: 'accessing instances and variables'!
inspectAllInstances
    "Inpsect all instances of the receiver.  1/26/96 sw"

    | all allSize prefix |
    all _ self allInstances.
    (allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no
instances of ', self name].
    prefix _ allSize == 1
        ifTrue:     ['The lone instance']
        ifFalse:    ['The ', allSize printString, ' instances'].

    all asArray inspectWithLabel: (prefix, ' of ', self name)! !

!Behavior methodsFor: 'accessing instances and variables'!
inspectSubInstances
    "Inspect all instances of the receiver and all its subclasses.  CAUTION - don't do this for something as generic as Object!!  1/26/96 sw"

    | all allSize prefix |
    all _ self allSubInstances.
    (allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no
instances of ', self name, '
or any of its subclasses'].
    prefix _ allSize == 1
        ifTrue:     ['The lone instance']
        ifFalse:    ['The ', allSize printString, ' instances'].

    all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! !

!Behavior methodsFor: 'accessing instances and variables'!
instanceCount
    "Answer the number of instances of the receiver that are currently in
    use."

    | count |
    count _ 0.
    self allInstancesDo: [:x | count _ count + 1].
    ^count! !

!Behavior methodsFor: 'accessing instances and variables'!
instVarNames
    "Answer an Array of the instance variable names. Behaviors must make
    up fake local instance variable names because Behaviors have instance
    variables for the purpose of compiling methods, but these are not named
    instance variables."

    | mySize superSize |
    mySize _ self instSize.
    superSize _
        superclass == nil
            ifTrue: [0]
            ifFalse: [superclass instSize].
    mySize = superSize ifTrue: [^#()].
    ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! !

!Behavior methodsFor: 'accessing instances and variables'!
sharedPools
    "Answer a Set of the names of the pools (Dictionaries) that the receiver
    shares.
    9/12/96 tk  sharedPools have an order now"

    ^ OrderedCollection new! !

!Behavior methodsFor: 'accessing instances and variables'!
someInstance
    "Primitive. Answer the first instance in the enumeration of all instances
    of the receiver. Fails if there are none. Essential. See Object
    documentation whatIsAPrimitive."

    <primitive: 77>
    ^nil! !

!Behavior methodsFor: 'accessing instances and variables'!
subclassInstVarNames
    "Answer a Set of the names of the receiver's subclasses' instance
    variables."
    | vars |
    vars _ Set new.
    self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames].
    ^vars! !


!Behavior methodsFor: 'testing class hierarchy'!
inheritsFrom: aClass
    "Answer whether the argument, aClass, is on the receiver's superclass
    chain."

    | aSuperclass |
    aSuperclass _ superclass.
    [aSuperclass == nil]
        whileFalse:
            [aSuperclass == aClass ifTrue: [^true].
            aSuperclass _ aSuperclass superclass].
    ^false! !

!Behavior methodsFor: 'testing class hierarchy'!
kindOfSubclass
    "Answer a String that is the keyword that describes the receiver's kind of
    subclass, either a regular subclass, a variableSubclass, a
    variableByteSubclass, or a variableWordSubclass."

    self isVariable
        ifTrue: [self isBits
                    ifTrue: [self isBytes
                                ifTrue: [^' variableByteSubclass: ']
                                ifFalse: [^' variableWordSubclass: ']]
                    ifFalse: [^' variableSubclass: ']]
        ifFalse: [^' subclass: ']! !


!Behavior methodsFor: 'testing method dictionary'!
allUnsentMessages
    "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system.  5/8/96 sw"

    ^ Smalltalk allUnSentMessagesIn: self selectors! !

!Behavior methodsFor: 'testing method dictionary'!
canUnderstand: selector
    "Answer whether the receiver can respond to the message whose selector
    is the argument. The selector can be in the method dictionary of the
    receiver's class or any of its superclasses."

    (self includesSelector: selector) ifTrue: [^true].
    superclass == nil ifTrue: [^false].
    ^superclass canUnderstand: selector! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'tk 9/13/97 09:53'!
classThatUnderstands: selector
    "Answer the class that can respond to the message whose selector
    is the argument. The selector can be in the method dictionary of the
    receiver's class or any of its superclasses."

    (self includesSelector: selector) ifTrue: [^ self].
    superclass == nil ifTrue: [^ nil].
    ^ superclass classThatUnderstands: selector! !

!Behavior methodsFor: 'testing method dictionary'!
hasMethods
    "Answer whether the receiver has any methods in its method dictionary."

    ^methodDict size > 0! !

!Behavior methodsFor: 'testing method dictionary'!
includesSelector: aSymbol
    "Answer whether the message whose selector is the argument is in the
    method dictionary of the receiver's class."

    ^methodDict includesKey: aSymbol! !

!Behavior methodsFor: 'testing method dictionary'!
scopeHas: name ifTrue: assocBlock
    "If the argument name is a variable known to the receiver, then evaluate
    the second argument, assocBlock."

    ^superclass scopeHas: name ifTrue: assocBlock! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 9/5/97 16:16'!
thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte
    "Answer a set of selectors whose methods access the argument as a literal.  Dives into the compact literal notation, making it slow but thorough"
    | who method |
    who _ Set new.
    methodDict associationsDo:
        [:assn |
        method _ assn value.
        ((method hasLiteralSuchThat: [:lit | lit == literal]) or:
                [specialFlag and: [method scanFor: specialByte]])
            ifTrue:
            [((literal isMemberOf: Association) not
                or: [method sendsToSuper not
                    or: [method literals allButLast includes: literal]])
                ifTrue: [who add: assn key]]].
    ^ who! !

!Behavior methodsFor: 'testing method dictionary'!
whichClassIncludesSelector: aSymbol
    "Answer the class on the receiver's superclass chain where the argument,
    aSymbol (a message selector), will be found. Answer nil if none found."

    (methodDict includesKey: aSymbol) ifTrue: [^self].
    superclass == nil ifTrue: [^nil].
    ^superclass whichClassIncludesSelector: aSymbol

    "Rectangle whichClassIncludesSelector: #inspect."! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsAccess: instVarName
    "Answer a Set of selectors whose methods access the argument,
    instVarName, as a named instance variable."

    | instVarIndex |
    instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
    ^methodDict keys select:
        [:sel |
        ((methodDict at: sel)
            readsField: instVarIndex)
            or: [(methodDict at: sel) writesField: instVarIndex]]

    "Point whichSelectorsAccess: 'x'."! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsReferTo: literal
    "Answer a Set of selectors whose methods access the argument as a literal."

    | special |
    special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:byte ].
    ^self whichSelectorsReferTo: literal special: special byte: byte

    "Rectangle whichSelectorsReferTo: #+."! !

!Behavior methodsFor: 'testing method dictionary' stamp: 'di 10/17/97 22:39'!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
    "Answer a set of selectors whose methods access the argument as a literal."
    | who method |
    who _ Set new.
    methodDict associationsDo:
        [:assn |
        method _ assn value.
        ((method hasLiteral: literal) or:
                [specialFlag and: [method scanFor: specialByte]])
            ifTrue:
            [((literal isMemberOf: Association) not
                or: [method sendsToSuper not
                    or: [method literals allButLast includes: literal]])
                ifTrue: [who add: assn key]]].
    ^who! !

!Behavior methodsFor: 'testing method dictionary'!
whichSelectorsStoreInto: instVarName
    "Answer a Set of selectors whose methods access the argument,
    instVarName, as a named instance variable."
    | instVarIndex |
    instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
    ^ methodDict keys select:
        [:sel | (methodDict at: sel) writesField: instVarIndex]

    "Point whichSelectorsStoreInto: 'x'."! !


!Behavior methodsFor: 'enumerating'!
allInstancesDo: aBlock
    "Evaluate the argument, aBlock, for each of the current instances of the
    receiver."
    | inst next |
    self ==  UndefinedObject ifTrue: [^ aBlock value: nil].
    inst _ self someInstance.
    [inst == nil]
        whileFalse:
        [aBlock value: inst.
        inst _ inst nextInstance]! !

!Behavior methodsFor: 'enumerating'!
allSubclassesDo: aBlock
    "Evaluate the argument, aBlock, for each of the receiver's subclasses."

    self subclassesDo:
        [:cl |
        aBlock value: cl.
        cl allSubclassesDo: aBlock]! !

!Behavior methodsFor: 'enumerating' stamp: 'di 6/20/97 10:50'!
allSubInstancesDo: aBlock
    "Evaluate the argument, aBlock, for each of the current instances of the
    receiver and all its subclasses."

    self allInstancesDo: aBlock.
    self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]! !

!Behavior methodsFor: 'enumerating'!
allSuperclassesDo: aBlock
    "Evaluate the argument, aBlock, for each of the receiver's superclasses."

    superclass == nil
        ifFalse: [aBlock value: superclass.
                superclass allSuperclassesDo: aBlock]! !

!Behavior methodsFor: 'enumerating'!
selectSubclasses: aBlock
    "Evaluate the argument, aBlock, with each of the receiver's (next level)
    subclasses as its argument. Collect into a Set only those subclasses for
    which aBlock evaluates to true. In addition, evaluate aBlock for the
    subclasses of each of these successful subclasses and collect into the set
    those for which aBlock evaluates true. Answer the resulting set."

    | aSet |
    aSet _ Set new.
    self allSubclasses do:
        [:aSubclass |
        (aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]].
    ^aSet! !

!Behavior methodsFor: 'enumerating'!
selectSuperclasses: aBlock
    "Evaluate the argument, aBlock, with the receiver's superclasses as the
    argument. Collect into an OrderedCollection only those superclasses for
    which aBlock evaluates to true. In addition, evaluate aBlock for the
    superclasses of each of these successful superclasses and collect into the
    OrderedCollection ones for which aBlock evaluates to true. Answer the
    resulting OrderedCollection."

    | aSet |
    aSet _ Set new.
    self allSuperclasses do:
        [:aSuperclass |
        (aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]].
    ^aSet! !

!Behavior methodsFor: 'enumerating'!
subclassesDo: aBlock
    "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
    subclasses == nil ifFalse:
        [subclasses do: [:cl | aBlock value: cl]]! !

!Behavior methodsFor: 'enumerating'!
withAllSubclassesDo: aBlock
    "Evaluate the argument, aBlock, for the receiver and each of its
    subclasses."

    aBlock value: self.
    self allSubclassesDo: aBlock! !


!Behavior methodsFor: 'user interface' stamp: 'sw 8/12/97 20:18'!
allCallsOn: aSymbol
    "Answer a SortedCollection of all the methods that call on aSymbol."

    | aSortedCollection special |
    aSortedCollection _ SortedCollection new.
    special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:byte ].
    self withAllSubclassesDo:
        [:class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do:
            [:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' ' , sel]]].
    ^aSortedCollection! !

!Behavior methodsFor: 'user interface' stamp: 'sw 2/23/98 00:48'!
browse
    Browser newOnClass: self! !

!Behavior methodsFor: 'user interface'!
browseAllAccessesTo: instVarName     "Collection browseAllAccessesTo: 'contents'."
    "Create and schedule a Message Set browser for all the receiver's methods
    or any methods of a subclass that refer to the instance variable name."
    | coll |
    coll _ OrderedCollection new.
    Cursor wait
        showWhile:
            [self withAllSubclasses do:
                [:class |
                (class whichSelectorsAccess: instVarName) do:
                    [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
            self allSuperclasses do:
                [:class |
                (class whichSelectorsAccess: instVarName) do:
                    [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
    ^ Smalltalk browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName! !

!Behavior methodsFor: 'user interface'!
browseAllCallsOn: aSymbol
    "Create and schedule a Message Set browser for all the methods that call
    on aSymbol."
    | key label |
    (aSymbol isKindOf: LookupKey)
            ifTrue: [label _ 'Users of ' , (key _ aSymbol key)]
            ifFalse: [label _ 'Senders of ' , (key _ aSymbol)].
    ^ Smalltalk browseMessageList: (self allCallsOn: aSymbol) asSortedCollection
        name: label autoSelect: key

    "Number browseAllCallsOn: #/."! !

!Behavior methodsFor: 'user interface'!
browseAllStoresInto: instVarName     "Collection browseAllStoresInto: 'contents'."
    "Create and schedule a Message Set browser for all the receiver's methods
    or any methods of a subclass that refer to the instance variable name."
    | coll |
    coll _ OrderedCollection new.
    Cursor wait
        showWhile:
            [self withAllSubclasses do:
                [:class |
                (class whichSelectorsStoreInto: instVarName) do:
                    [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
            self allSuperclasses do:
                [:class |
                (class whichSelectorsStoreInto: instVarName) do:
                    [:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
    ^ Smalltalk browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName! !

!Behavior methodsFor: 'user interface'!
crossReference
    "Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."

    ^self selectors asSortedCollection asArray collect: [:x |         Array
            with: (String with: Character cr), x
            with: (self whichSelectorsReferTo: x)]

    "Point crossReference."! !

!Behavior methodsFor: 'user interface' stamp: 'sw 2/4/98 15:21'!
removeUninstantiatedSubclassesSilently
    "Remove the classes of any subclasses that have neither instances nor subclasses.  Answer the number of bytes reclaimed"
    "Player removeUninstantiatedSubclassesSilently"

    | candidatesForRemoval  oldFree |

    oldFree _ Smalltalk garbageCollect.
    candidatesForRemoval _
        self subclasses select: [:c |
            (c instanceCount = 0) and: [c subclasses size = 0]].
    candidatesForRemoval do: [:c | c removeFromSystem].
    ^ Smalltalk garbageCollect - oldFree! !

!Behavior methodsFor: 'user interface'!
unreferencedInstanceVariables
    "Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses.  2/26/96 sw"

    | any |

    ^ self instVarNames copy reject:
        [:ivn | any _ false.
        self withAllSubclasses do:
            [:class |  (class whichSelectorsAccess: ivn) do:
                    [:sel | sel ~~ #DoIt ifTrue: [any _ true]]].
        any]

"Ob unreferencedInstanceVariables"! !


!Behavior methodsFor: 'private'!
becomeCompact
    | cct index |
    cct _ Smalltalk compactClassesArray.
    (self indexIfCompact > 0 or: [cct includes: self])
        ifTrue: [^ self halt: self name , 'is already compact'].
    index _ cct indexOf: nil
        ifAbsent: [^ self halt: 'compact class table is full'].
    "Install this class in the compact class table"
    cct at: index put: self.
    "Update instspec so future instances will be compact"
    format _ format + (index bitShift: 11).
    "Make up new instances and become old ones into them"
    self updateInstancesFrom: self.
    "Purge any old instances"
    Smalltalk garbageCollect.! !

!Behavior methodsFor: 'private'!
becomeUncompact
    | cct index |
    cct _ Smalltalk compactClassesArray.
    (index _ self indexIfCompact) = 0
        ifTrue: [^ self].
    (cct includes: self)
        ifFalse: [^ self halt  "inconsistent state"].
    "Update instspec so future instances will not be compact"
    format _ format - (index bitShift: 11).
    "Make up new instances and become old ones into them"
    self updateInstancesFrom: self.
    "Make sure there are no compact ones left around"
    Smalltalk garbageCollect.
    "Remove this class from the compact class table"
    cct at: index put: nil.
! !

!Behavior methodsFor: 'private'!
flushCache
    "Tell the interpreter to remove the contents of its method lookup cache, if it has
    one.  Essential.  See Object documentation whatIsAPrimitive."

    <primitive: 89>
    self primitiveFailed! !

!Behavior methodsFor: 'private'!
format: nInstVars variable: isVar words: isWords pointers: isPointers
    "Set the format for the receiver (a Class)."
    | cClass instSpec sizeHiBits |
    self flag: #instSizeChange.
"
Smalltalk browseAllCallsOn: #instSizeChange.
Smalltalk browseAllImplementorsOf: #fixedFieldsOf:.
Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:.
"
"
    NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
    For now the format word is...
        <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0>
    But when we revise the image format, it should become...
        <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0>
"
    sizeHiBits _ (nInstVars+1) // 64.
    cClass _ 0.  "for now"
    instSpec _ isPointers
        ifTrue: [isVar
                ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]]
                ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]]
        ifFalse: [isWords ifTrue: [6] ifFalse: [8]].
    format _ sizeHiBits.
    format _ (format bitShift: 5) + cClass.
    format _ (format bitShift: 4) + instSpec.
    format _ (format bitShift: 6) + ((nInstVars+1)\\64).  "+1 since prim size field includes header"
    format _ (format bitShift: 1) "This shift plus integer bit lets wordSize work like byteSize"
! !

!Behavior methodsFor: 'private'!
indexIfCompact
    "If these 5 bits are non-zero, then instances of this class
    will be compact.  It is crucial that there be an entry in
    Smalltalk compactClassesArray for any class so optimized.
    See the msgs becomeCompact and becomeUncompact."
    ^ (format bitShift: -11) bitAnd: 16r1F
"
Smalltalk compactClassesArray doWithIndex:
    [:c :i | c == nil ifFalse:
        [c indexIfCompact = i ifFalse: [self halt]]]
"! !

!Behavior methodsFor: 'private'!
printSubclassesOn: aStream level: level
    "As part of the algorithm for printing a description of the receiver, print the
    subclass on the file stream, aStream, indenting level times."

    | subclassNames subclass |
    aStream crtab: level.
    aStream nextPutAll: self name.
    aStream space; print: self instVarNames.
    self == Class
        ifTrue:
            [aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'.
            ^self].
    subclassNames _ self subclasses collect: [:subC | subC name].
    "Print subclasses in alphabetical order"
    subclassNames asSortedCollection do:
        [:name |
        subclass _ self subclasses detect: [:subC | subC name = name].
        subclass printSubclassesOn: aStream level: level + 1]! !

!Behavior methodsFor: 'private' stamp: 'di 12/26/97 11:07'!
removeSelectorSimply: selector
    "Remove the message selector from the receiver's method dictionary.
    Internal access from compiler."

    methodDict removeKey: selector ifAbsent: [^self].
    selector flushCache! !
Object subclass: #BitBlt
    instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Support'!
!BitBlt commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitBlt comment:
'I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm.  The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm.  If both are specified, their pixel values are combined with a logical AND function prior to transfer.  In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.

The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows:
    8:    if source is 0 and destination is 0
    4:    if source is 0 and destination is 1
    2:    if source is 1 and destination is 0
    1:    if source is 1 and destination is 1.
At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions;  if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero.  Forms may be of different depths, see the comment in class Form.

In addition to the original 16 combination rules, this BitBlt supports
    16    fails (to simulate paint bits)
    17    fails (to simulate erase bits)
    18    sourceWord + destinationWord
    19    sourceWord - destinationWord
    20    rgbAdd: sourceWord with: destinationWord.  Sum of color components
    21    rgbSub: sourceWord with: destinationWord.  Sum of color components
    22    rgbDiff: sourceWord with: destinationWord.  Sum of abs of differences in components
    23    tallyIntoMap: destinationWord
    24    alphaBlend: sourceWord with: destinationWord
    25    pixPaint: sourceWord with: destinationWord.  Wherever the sourceForm is non-zero, it replaces the destination.  Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1.
    26    pixMask: sourceWord with: destinationWord.  Like pixPaint, but fills with 0.
    27    rgbMax: sourceWord with: destinationWord.  Max of each color component.
    28    rgbMin: sourceWord with: destinationWord.  Min of each color component.
    29    rgbMin: sourceWord bitInvert32 with: destinationWord.  Min with (max-source)

The color specified by halftoneForm may be either a Color or a Pattern.   A Color is converted to a pixelValue for the depth of the destinationForm.  If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary.  Within each scan line the 32-bit value is repeated from left to right across the form.  If the value repeats on pixels boudaries, the effect will be a constant color;  if not, it will produce a halftone that repeats on 32-bit boundaries.

Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms.
    To make a small Form repeat and fill a big form, use an InfiniteForm as the source.
    To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source.

Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap.  If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits.  The colorMap, if specified, must be a word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source.  For every source pixel, BitBlt will then index this array, and select the corresponding pixelValue and mask it to the destination pixel size before storing.
    When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation.  This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color.  Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped.  The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1.  Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color).
    Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors.
    Colors can be remapped at the same depth.  Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file.  Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of.  MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)'!


!BitBlt methodsFor: 'accessing'!
clipHeight: anInteger
    "Set the receiver's clipping area height to be the argument, anInteger."

    clipHeight _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipRect
    "Answer the receiver's clipping area rectangle."

    ^clipX @ clipY extent: clipWidth @ clipHeight! !

!BitBlt methodsFor: 'accessing'!
clipRect: aRectangle
    "Set the receiver's clipping area rectangle to be the argument, aRectangle."

    clipX _ aRectangle left.
    clipY _ aRectangle top.
    clipWidth _ aRectangle width.
    clipHeight _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
clipWidth: anInteger
    "Set the receiver's clipping area width to be the argument, anInteger."

    clipWidth _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipX: anInteger
    "Set the receiver's clipping area top left x coordinate to be the argument,
    anInteger."

    clipX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
clipY: anInteger
    "Set the receiver's clipping area top left y coordinate to be the argument,
    anInteger."

    clipY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
colorMap
    ^ colorMap! !

!BitBlt methodsFor: 'accessing'!
colorMap: map
    "See last part of BitBlt comment. 6/18/96 tk"
    colorMap _ map! !

!BitBlt methodsFor: 'accessing'!
combinationRule: anInteger
    "Set the receiver's combination rule to be the argument, anInteger, a
    number in the range 0-15."

    combinationRule _ anInteger! !

!BitBlt methodsFor: 'accessing'!
destForm
    ^ destForm! !

!BitBlt methodsFor: 'accessing'!
destOrigin: aPoint
    "Set the receiver's destination top left coordinates to be those of the
    argument, aPoint."

    destX _ aPoint x.
    destY _ aPoint y! !

!BitBlt methodsFor: 'accessing' stamp: 'tk 3/19/97'!
destRect
    "The rectangle we are about to blit to or just blitted to.  "

    ^ destX @ destY extent: width @ height! !

!BitBlt methodsFor: 'accessing'!
destRect: aRectangle
    "Set the receiver's destination form top left coordinates to be the origin of
    the argument, aRectangle, and set the width and height of the receiver's
    destination form to be the width and height of aRectangle."

    destX _ aRectangle left.
    destY _ aRectangle top.
    width _ aRectangle width.
    height _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
destX: anInteger
    "Set the top left x coordinate of the receiver's destination form to be the
    argument, anInteger."

    destX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
destX: x destY: y width: w height: h
    "Combined init message saves 3 sends from DisplayScanner"
    destX _ x.
    destY _ y.
    width _ w.
    height _ h.! !

!BitBlt methodsFor: 'accessing'!
destY: anInteger
    "Set the top left y coordinate of the receiver's destination form to be the
    argument, anInteger."

    destY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
fillColor
    ^ halftoneForm! !

!BitBlt methodsFor: 'accessing'!
fillColor: aColorOrPattern
    "The destForm will be filled with this color or pattern of colors.  May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form.  6/18/96 tk"

    aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self].
    destForm == nil ifTrue: [self error: 'Must set destForm first'].
    halftoneForm _ aColorOrPattern bitPatternForDepth: destForm depth! !

!BitBlt methodsFor: 'accessing'!
height: anInteger
    "Set the receiver's destination form height to be the argument, anInteger."

    height _ anInteger! !

!BitBlt methodsFor: 'accessing'!
sourceForm

    ^ sourceForm! !

!BitBlt methodsFor: 'accessing'!
sourceForm: aForm
    "Set the receiver's source form to be the argument, aForm."

    sourceForm _ aForm! !

!BitBlt methodsFor: 'accessing'!
sourceOrigin: aPoint
    "Set the receiver's source form coordinates to be those of the argument,
    aPoint."

    sourceX _ aPoint x.
    sourceY _ aPoint y! !

!BitBlt methodsFor: 'accessing'!
sourceRect: aRectangle
    "Set the receiver's source form top left x and y, width and height to be
    the top left coordinate and extent of the argument, aRectangle."

    sourceX _ aRectangle left.
    sourceY _ aRectangle top.
    width _ aRectangle width.
    height _ aRectangle height! !

!BitBlt methodsFor: 'accessing'!
sourceX: anInteger
    "Set the receiver's source form top left x to be the argument, anInteger."

    sourceX _ anInteger! !

!BitBlt methodsFor: 'accessing'!
sourceY: anInteger
    "Set the receiver's source form top left y to be the argument, anInteger."

    sourceY _ anInteger! !

!BitBlt methodsFor: 'accessing'!
width: anInteger
    "Set the receiver's destination form width to be the argument, anInteger."

    width _ anInteger! !


!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm
    | destOrigin |
    sourceForm _ srcForm.
    halftoneForm _ nil.
    combinationRule _ 3.  "store"
    destOrigin _ destRectangle origin.
    destX _ destOrigin x.
    destY _ destOrigin y.
    sourceX _ sourcePt x.
    sourceY _ sourcePt y.
    width _ destRectangle width.
    height _ destRectangle height.
    self copyBits! !

!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
    "Specify a Color to fill, not a Form. 6/18/96 tk"
    | destOrigin |
    sourceForm _ srcForm.
    self fillColor: hf.    "sets halftoneForm"
    combinationRule _ rule.
    destOrigin _ destRectangle origin.
    destX _ destOrigin x.
    destY _ destOrigin y.
    sourceX _ sourcePt x.
    sourceY _ sourcePt y.
    width _ destRectangle width.
    height _ destRectangle height.
    ^ self copyBits! !

!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule
    | destOrigin |
    sourceForm _ srcForm.
    self fillColor: hf.        "sets halftoneForm"
    combinationRule _ rule.
    destOrigin _ destRectangle origin.
    destX _ destOrigin x.
    destY _ destOrigin y.
    sourceX _ sourcePt x.
    sourceY _ sourcePt y.
    width _ destRectangle width.
    height _ destRectangle height.
    self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 3/2/98 14:06'!
copyBits
    "Primitive. Perform the movement of bits from the source form to the
    destination form. Fail if any variables are not of the right type (Integer,
    Float, or Form) or if the combination rule is not implemented.
    In addition to the original 16 combination rules, this BitBlt supports
    16    fail (to simulate paint)
    17    fail (to simulate mask)
    18    sourceWord + destinationWord
    19    sourceWord - destinationWord
    20    rgbAdd: sourceWord with: destinationWord
    21    rgbSub: sourceWord with: destinationWord
    22    rgbDiff: sourceWord with: destinationWord
    23    tallyIntoMap: destinationWord
    24    alphaBlend: sourceWord with: destinationWord
    25    pixPaint: sourceWord with: destinationWord
    26    pixMask: sourceWord with: destinationWord
    27    rgbMax: sourceWord with: destinationWord
    28    rgbMin: sourceWord with: destinationWord
    29    rgbMin: sourceWord bitInvert32 with: destinationWord
"
    <primitive: 96>

    "Check for compressed source, destination or halftone forms"
    ((sourceForm isKindOf: Form) and: [sourceForm unhibernate])
        ifTrue: [^ self copyBits].
    ((destForm isKindOf: Form) and: [destForm unhibernate])
        ifTrue: [^ self copyBits].
    ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate])
        ifTrue: [^ self copyBits].

    "Check for unimplmented rules"
    combinationRule = Form oldPaint ifTrue: [^ self paintBits].
    combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits].

    self halt: 'Bad BitBlt arg (Fraction?); proceed to convert.'.
    "Convert all numeric parameters to integers and try again."
    destX _ destX asInteger.
    destY _ destY asInteger.
    width _ width asInteger.
    height _ height asInteger.
    sourceX _ sourceX asInteger.
    sourceY _ sourceY asInteger.
    clipX _ clipX asInteger.
    clipY _ clipY asInteger.
    clipWidth _ clipWidth asInteger.
    clipHeight _ clipHeight asInteger.
    ^ self copyBitsAgain! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!
copyForm: srcForm to: destPt rule: rule
    ^ self copyForm: srcForm to: destPt rule: rule
        colorMap: (srcForm colormapIfNeededForDepth: destForm depth)! !

!BitBlt methodsFor: 'copying'!
copyForm: srcForm to: destPt rule: rule color: color
    sourceForm _ srcForm.
    halftoneForm _ color.
    combinationRule _ rule.
    destX _ destPt x + sourceForm offset x.
    destY _ destPt y + sourceForm offset y.
    sourceX _ 0.
    sourceY _ 0.
    width _ sourceForm width.
    height _ sourceForm height.
    self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/17/97 10:04'!
copyForm: srcForm to: destPt rule: rule colorMap: map
    sourceForm _ srcForm.
    halftoneForm _ nil.
    combinationRule _ rule.
    destX _ destPt x + sourceForm offset x.
    destY _ destPt y + sourceForm offset y.
    sourceX _ 0.
    sourceY _ 0.
    width _ sourceForm width.
    height _ sourceForm height.
    colorMap _ map.
    self copyBits! !

!BitBlt methodsFor: 'copying'!
copyForm: srcForm to: destPt rule: rule fillColor: color
    sourceForm _ srcForm.
    self fillColor: color.    "sets halftoneForm"
    combinationRule _ rule.
    destX _ destPt x + sourceForm offset x.
    destY _ destPt y + sourceForm offset y.
    sourceX _ 0.
    sourceY _ 0.
    width _ sourceForm width.
    height _ sourceForm height.
    self copyBits! !

!BitBlt methodsFor: 'copying' stamp: 'di 7/1/97 14:09'!
copyFrom: sourceRectangle in: srcForm to: destPt
    | sourceOrigin |
    sourceForm _ srcForm.
    halftoneForm _ nil.
    combinationRule _ 3.  "store"
    destX _ destPt x.
    destY _ destPt y.
    sourceOrigin _ sourceRectangle origin.
    sourceX _ sourceOrigin x.
    sourceY _ sourceOrigin y.
    width _ sourceRectangle width.
    height _ sourceRectangle height.
    colorMap _ srcForm colormapIfNeededForDepth: destForm depth.
    self copyBits! !

!BitBlt methodsFor: 'copying'!
fill: destRect fillColor: grayForm rule: rule
    "Fill with a Color, not a Form. 6/18/96 tk"
    sourceForm _ nil.
    self fillColor: grayForm.        "sets halftoneForm"
    combinationRule _ rule.
    destX _ destRect left.
    destY _ destRect top.
    sourceX _ 0.
    sourceY _ 0.
    width _ destRect width.
    height _ destRect height.
    self copyBits! !

!BitBlt methodsFor: 'copying'!
pixelAt: aPoint
    "Assumes this BitBlt has been set up specially (see the init message,
    BitBlt bitPeekerFromForm:.  Returns the pixel at aPoint."
    sourceX _ aPoint x.
    sourceY _ aPoint y.
    destForm bits at: 1 put: 0.  "Just to be sure"
    self copyBits.
    ^ destForm bits at: 1! !

!BitBlt methodsFor: 'copying'!
pixelAt: aPoint put: pixelValue
    "Assumes this BitBlt has been set up specially (see the init message,
    BitBlt bitPokerToForm:.  Overwrites the pixel at aPoint."
    destX _ aPoint x.
    destY _ aPoint y.
    sourceForm bits at: 1 put: pixelValue.
    self copyBits
"
| bb |
bb _ (BitBlt bitPokerToForm: Display).
[Sensor anyButtonPressed] whileFalse:
    [bb pixelAt: Sensor cursorPoint put: 55]
"! !


!BitBlt methodsFor: 'line drawing'!
drawFrom: startPoint to: stopPoint

     ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! !

!BitBlt methodsFor: 'line drawing' stamp: '6/8/97 15:41 di'!
drawFrom: startPoint to: stopPoint withFirstPoint: drawFirstPoint
    "Draw a line whose end points are startPoint and stopPoint.
    The line is formed by repeatedly calling copyBits at every
    point along the line.  If drawFirstPoint is false, then omit
    the first point so as not to overstrike at line junctions."
    | offset point1 point2 forwards |
    "Always draw down, or at least left-to-right"
    forwards _ (startPoint y = stopPoint y and: [startPoint x < stopPoint x])
                or: [startPoint y < stopPoint y].
    forwards
        ifTrue: [point1 _ startPoint. point2 _ stopPoint]
        ifFalse: [point1 _ stopPoint. point2 _ startPoint].
    sourceForm == nil ifTrue:
        [destX _ point1 x.
        destY _ point1 y]
        ifFalse:
        [width _ sourceForm width.
        height _ sourceForm height.
        offset _ sourceForm offset.
        destX _ (point1 x + offset x) rounded.
        destY _ (point1 y + offset y) rounded].

    "Note that if not forwards, then the first point is the last and vice versa.
    We agree to always paint stopPoint, and to optionally paint startPoint."
    (drawFirstPoint or: [forwards == false  "ie this is stopPoint"])
        ifTrue: [self copyBits].
    self drawLoopX: (point2 x - point1 x) rounded
                  Y: (point2 y - point1 y) rounded.
    (drawFirstPoint or: [forwards  "ie this is stopPoint"])
        ifTrue: [self copyBits].
! !

!BitBlt methodsFor: 'line drawing'!
drawLoopX: xDelta Y: yDelta
    "Primitive. Implements the Bresenham plotting algorithm (IBM Systems
    Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and
    maintains a potential, P. When P's sign changes, it is time to move in
    the minor direction as well. This particular version does not write the
    first and last points, so that these can be called for as needed in client code.
    Optional. See Object documentation whatIsAPrimitive."
    | dx dy px py P |
    <primitive: 104>
    dx _ xDelta sign.
    dy _ yDelta sign.
    px _ yDelta abs.
    py _ xDelta abs.
    "self copyBits."
    py > px
        ifTrue:
            ["more horizontal"
            P _ py // 2.
            1 to: py do:
                [:i |
                destX _ destX + dx.
                (P _ P - px) < 0 ifTrue:
                        [destY _ destY + dy.
                        P _ P + py].
                i < py ifTrue: [self copyBits]]]
        ifFalse:
            ["more vertical"
            P _ px // 2.
            1 to: px do:
                [:i |
                destY _ destY + dy.
                (P _ P - py) < 0 ifTrue:
                        [destX _ destX + dx.
                        P _ P + px].
                i < px ifTrue: [self copyBits]]]! !


!BitBlt methodsFor: 'private'!
copyBitsAgain
    "Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
    documentation whatIsAPrimitive."

    <primitive: 96>
    self primitiveFailed! !

!BitBlt methodsFor: 'private'!
eraseBits
    "Perform the erase operation, which puts 0's in the destination
    wherever the source (which is assumed to be just 1 bit deep)
    has a 1.  This requires the colorMap to be set in order to AND
    all 1's into the destFrom pixels regardless of their size."
    | oldMask oldMap |
    oldMask _ halftoneForm.
    halftoneForm _ nil.
    oldMap _ colorMap.
    self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
    combinationRule _ Form erase.
    self copyBits.         "Erase the dest wherever the source is 1"
    halftoneForm _ oldMask.    "already converted to a Bitmap"
    colorMap _ oldMap! !

!BitBlt methodsFor: 'private'!
paintBits
    "Perform the paint operation, which requires two calls to BitBlt."
    | color oldMap saveRule |
    sourceForm depth = 1 ifFalse:
        [^ self halt: 'paint operation is only defined for 1-bit deep sourceForms'].
    saveRule _ combinationRule.
    color _ halftoneForm.  halftoneForm _ nil.
    oldMap _ colorMap.
    "Map 1's to ALL ones, not just one"
    self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
    combinationRule _ Form erase.
    self copyBits.         "Erase the dest wherever the source is 1"
    halftoneForm _ color.
    combinationRule _ Form under.
    self copyBits.    "then OR, with whatever color, into the hole"
    colorMap _ oldMap.
    combinationRule _ saveRule

" | dot |
dot _ Form dotOfSize: 32.
((BitBlt destForm: Display
        sourceForm: dot
        fillColor: Color lightGray
        combinationRule: Form paint
        destOrigin: Sensor cursorPoint
        sourceOrigin: 0@0
        extent: dot extent
        clipRect: Display boundingBox)
        colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits"! !

!BitBlt methodsFor: 'private'!
setDestForm: df
    | bb |
    bb _ df boundingBox.
    destForm _ df.
    clipX _ bb left.
    clipY _ bb top.
    clipWidth _ bb width.
    clipHeight _ bb height! !

!BitBlt methodsFor: 'private'!
setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect

    | aPoint |
    destForm _ df.
    sourceForm _ sf.
    self fillColor: hf.    "sets halftoneForm"
    combinationRule _ cr.
    destX _ destOrigin x.
    destY _ destOrigin y.
    sourceX _ sourceOrigin x.
    sourceY _ sourceOrigin y.
    width _ extent x.
    height _ extent y.
    aPoint _ clipRect origin.
    clipX _ aPoint x.
    clipY _ aPoint y.
    aPoint _ clipRect corner.
    clipWidth _ aPoint x - clipX.
    clipHeight _ aPoint y - clipY.
    colorMap _ sourceForm colormapIfNeededForDepth: destForm depth.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBlt class
    instanceVariableNames: ''!

!BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'!
bitPeekerFromForm: sourceForm
    "Answer an instance to be used extract individual pixels from the given Form. The destination for a 1x1 copyBits will be the low order bits of (bits at: 1)."
    | pixPerWord |
    pixPerWord _ 32 // sourceForm depth.
    sourceForm unhibernate.
    ^ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth)
         sourceForm: sourceForm
        halftoneForm: nil
        combinationRule: Form over
        destOrigin: (pixPerWord - 1)@0
        sourceOrigin: 0@0
        extent: 1@1
        clipRect: (0@0 extent: pixPerWord@1)
! !

!BitBlt class methodsFor: 'instance creation' stamp: 'di 3/2/98 12:53'!
bitPokerToForm: destForm
    "Answer an instance to be used for valueAt: aPoint put: pixValue.
    The source for a 1x1 copyBits will be the low order of (bits at: 1)"
    | pixPerWord |
    pixPerWord _ 32//destForm depth.
    destForm unhibernate.
    ^ self destForm: destForm
         sourceForm: (Form extent: pixPerWord@1 depth: destForm depth)
        halftoneForm: nil combinationRule: Form over
        destOrigin: 0@0 sourceOrigin: (pixPerWord-1)@0
        extent: 1@1 clipRect: (0@0 extent: destForm extent)
! !

!BitBlt class methodsFor: 'instance creation'!
destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect
    "Answer an instance of me with values set according to the arguments."

    ^ self new
        setDestForm: df
        sourceForm: sf
        fillColor: hf
        combinationRule: cr
        destOrigin: destOrigin
        sourceOrigin: sourceOrigin
        extent: extent
        clipRect: clipRect! !

!BitBlt class methodsFor: 'instance creation'!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect
    "Answer an instance of me with values set according to the arguments."

    ^ self new
        setDestForm: df
        sourceForm: sf
        fillColor: hf
        combinationRule: cr
        destOrigin: destOrigin
        sourceOrigin: sourceOrigin
        extent: extent
        clipRect: clipRect! !

!BitBlt class methodsFor: 'instance creation'!
toForm: aForm
    ^ self new setDestForm: aForm! !


!BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:08'!
alphaBlendDemo
    "To run this demo, use...
        Display restoreAfter: [BitBlt alphaBlendDemo]
    Displays 10 alphas, then lets you paint.  Option-Click to stop painting."

    "This code exhibits alpha blending in any display depth by performing
    the blend in an off-screen buffer with 32-bit pixels, and then copying
    the result back onto the screen with an appropriate color map. - tk 3/10/97"

    "This version uses a sliding buffer for painting that keeps pixels in 32 bits
    as long as they are in the buffer, so as not to lose info by converting down
    to display resolution and back up to 32 bits at each operation. - di 3/15/97"

    | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect |

    "compute color maps if needed"
    Display depth <= 8 ifTrue: [
        mapDto32 _ Color cachedColormapFrom: Display depth to: 32.
        map32toD _ Color cachedColormapFrom: 32 to: Display depth].

    "display 10 different alphas, across top of screen"
    buff _ Form extent: 500@50 depth: 32.
    dispToBuff _ BitBlt toForm: buff.
    dispToBuff colorMap: mapDto32.
    dispToBuff copyFrom: (50@10 extent: 500@50) in: Display to: 0@0.
    1 to: 10 do: [:i | dispToBuff fill: (50*(i-1)@0 extent: 50@50)
                        fillColor: (Color red alpha: i/10)
                        rule: Form blend].
    buffToDisplay _ BitBlt toForm: Display.
    buffToDisplay colorMap: map32toD.
    buffToDisplay copyFrom: buff boundingBox in: buff to: 50@10.

    "Create a brush with radially varying alpha"
    brush _ Form extent: 30@30 depth: 32.
    1 to: 5 do:
        [:i | brush fillShape: (Form dotOfSize: brush width*(6-i)//5)
                fillColor: (Color red alpha: 0.02 * i - 0.01)
                at: brush extent // 2].

    "Now paint with the brush using alpha blending."
    buffSize _ 100.
    buff _ Form extent: brush extent + buffSize depth: 32.  "Travelling 32-bit buffer"
    dispToBuff _ BitBlt toForm: buff.  "This is from Display to buff"
    dispToBuff colorMap: mapDto32.
    brushToBuff _ BitBlt toForm: buff.  "This is from brush to buff"
    brushToBuff sourceForm: brush; sourceOrigin: 0@0.
    brushToBuff combinationRule: Form blend.
    buffToBuff _ BitBlt toForm: buff.  "This is for slewing the buffer"

    [Sensor yellowButtonPressed] whileFalse:
        [prevP _ nil.
        buffRect _ Sensor cursorPoint - (buffSize // 2) extent: buff extent.
        dispToBuff copyFrom: buffRect in: Display to: 0@0.
        [Sensor redButtonPressed] whileTrue:
            ["Here is the painting loop"
            p _ Sensor cursorPoint - (brush extent // 2).
            (prevP == nil or: [prevP ~= p]) ifTrue:
                [prevP == nil ifTrue: [prevP _ p].
                (p dist: prevP) > buffSize ifTrue:
                    ["Stroke too long to fit in buffer -- clip to buffer,
                        and next time through will do more of it"
                    theta _ (p-prevP) theta.
                    p _ ((theta cos@theta sin) * buffSize asFloat + prevP) truncated].
                brushRect _ p extent: brush extent.
                (buffRect containsRect: brushRect) ifFalse:
                    ["Brush is out of buffer region.  Scroll the buffer,
                        and fill vacated regions from the display"
                    delta _ brushRect amountToTranslateWithin: buffRect.
                    buffToBuff copyFrom: buff boundingBox in: buff to: delta.
                    newBuffRect _ buffRect translateBy: delta negated.
                    (newBuffRect areasOutside: buffRect) do:
                        [:r | dispToBuff copyFrom: r in: Display to: r origin - newBuffRect origin].
                    buffRect _ newBuffRect].

                "Interpolate from prevP to p..."
                brushToBuff drawFrom: prevP - buffRect origin
                                    to: p - buffRect origin
                                    withFirstPoint: false.

                "Update (only) the altered pixels of the destination"
                updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent.
                buffToDisplay copy: updateRect from: updateRect origin - buffRect origin in: buff.
                prevP _ p]]]! !

!BitBlt class methodsFor: 'examples' stamp: 'di 12/1/97 12:09'!
antiAliasDemo
    "To run this demo, use...
        Display restoreAfter: [BitBlt antiAliasDemo]
    Goes immediately into on-screen paint mode.  Option-Click to stop painting."

    "This code exhibits alpha blending in any display depth by performing
    the blend in an off-screen buffer with 32-bit pixels, and then copying
    the result back onto the screen with an appropriate color map. - tk 3/10/97"

    "This version uses a sliding buffer for painting that keeps pixels in 32 bits
    as long as they are in the buffer, so as not to lose info by converting down
    to display resolution and back up to 32 bits at each operation. - di 3/15/97"

    "This version also uses WarpBlt to paint into twice as large a buffer,
    and then use smoothing when reducing back down to the display.
    In fact this same routine will now work for 3x3 soothing as well.
    Remove the statements 'buff displayAt: 0@0' to hide the buffer. - di 3/19/97"

    | brush buff dispToBuff buffToDisplay mapDto32 map32toD prevP p brushToBuff theta buffRect buffSize buffToBuff brushRect delta newBuffRect updateRect scale p0 |
    "compute color maps if needed"
    Display depth <= 8 ifTrue: [
        mapDto32 _ Color cachedColormapFrom: Display depth to: 32.
        map32toD _ Color cachedColormapFrom: 32 to: Display depth].

    "Create a brush with radially varying alpha"
    brush _ Form extent: 3@3 depth: 32.
    brush fill: brush boundingBox fillColor: (Color red alpha: 0.05).
    brush fill: (1@1 extent: 1@1) fillColor: (Color red alpha: 0.2).

    scale _ 2.  "Actual drawing happens at this magnification"
    "Scale brush up for painting in magnified buffer"
    brush _ brush magnify: brush boundingBox by: scale.

    "Now paint with the brush using alpha blending."
    buffSize _ 100.
    buff _ Form extent: (brush extent + buffSize) * scale depth: 32.  "Travelling 32-bit buffer"
    dispToBuff _ (WarpBlt toForm: buff)  "From Display to buff - magnify by 2"
        sourceForm: Display;
        colorMap: mapDto32;
        combinationRule: Form over.
    brushToBuff _ (BitBlt toForm: buff)  "From brush to buff"
        sourceForm: brush;
        sourceOrigin: 0@0;
        combinationRule: Form blend.
    buffToDisplay _ (WarpBlt toForm: Display)  "From buff to Display - shrink by 2"
        sourceForm: buff;
        colorMap: map32toD;
        cellSize: scale;  "...and use smoothing"
        combinationRule: Form over.
    buffToBuff _ BitBlt toForm: buff.  "This is for slewing the buffer"

    [Sensor yellowButtonPressed] whileFalse:
        [prevP _ nil.
        buffRect _ Sensor cursorPoint - (buff extent // scale // 2) extent: buff extent // scale.
        p0 _ (buff extent // 2) - (buffRect extent // 2).
        dispToBuff copyQuad: buffRect innerCorners toRect: buff boundingBox.
buff displayAt: 0@0.  "** remove to hide sliding buffer **"
        [Sensor redButtonPressed] whileTrue:
            ["Here is the painting loop"
            p _ Sensor cursorPoint - buffRect origin + p0.  "p, prevP are rel to buff origin"
            (prevP == nil or: [prevP ~= p]) ifTrue:
                [prevP == nil ifTrue: [prevP _ p].
                (p dist: prevP) > (buffSize-1) ifTrue:
                    ["Stroke too long to fit in buffer -- clip to buffer,
                        and next time through will do more of it"
                    theta _ (p-prevP) theta.
                    p _ ((theta cos@theta sin) * (buffSize-2) asFloat + prevP) truncated].
                brushRect _ p extent: brush extent.
                ((buff boundingBox insetBy: scale) containsRect: brushRect) ifFalse:
                    ["Brush is out of buffer region.  Scroll the buffer,
                        and fill vacated regions from the display"
                    delta _ (brushRect amountToTranslateWithin: (buff boundingBox insetBy: scale)) // scale.
                    buffToBuff copyFrom: buff boundingBox in: buff to: delta*scale.
                    newBuffRect _ buffRect translateBy: delta negated.
                    p _ p translateBy: delta*scale.
                    prevP _ prevP translateBy: delta*scale.
                    (newBuffRect areasOutside: buffRect) do:
                        [:r | dispToBuff copyQuad: r innerCorners toRect: (r origin - newBuffRect origin*scale extent: r extent*scale)].
                    buffRect _ newBuffRect].

                "Interpolate from prevP to p..."
                brushToBuff drawFrom: prevP to: p withFirstPoint: false.
buff displayAt: 0@0.  "** remove to hide sliding buffer **"

                "Update (only) the altered pixels of the destination"
                updateRect _ (p min: prevP) corner: (p max: prevP) + brush extent.
                updateRect _ updateRect origin // scale * scale
                        corner: updateRect corner + scale // scale * scale.
                buffToDisplay copyQuad: updateRect innerCorners
                            toRect: (updateRect origin // scale + buffRect origin
                                        extent: updateRect extent // scale).
                prevP _ p]]]! !

!BitBlt class methodsFor: 'examples'!
exampleOne
    "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules)."
    | path |
    path _ Path new.
    0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]].
    Display fillWhite.
    path _ path translateBy: 60 @ 40.
    1 to: 16 do: [:index | BitBlt
            exampleAt: (path at: index)
            rule: index - 1
            fillColor: Color black]

    "BitBlt exampleOne"! !

!BitBlt class methodsFor: 'examples'!
exampleTwo
    "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops."
    | f aBitBlt |
    "create a small black Form source as a brush. "
    f _ Form extent: 20 @ 20.
    f fillBlack.
    "create a BitBlt which will OR gray into the display. "
    aBitBlt _ BitBlt
        destForm: Display
        sourceForm: f
        fillColor: Color gray
        combinationRule: Form under
        destOrigin: Sensor cursorPoint
        sourceOrigin: 0 @ 0
        extent: f extent
        clipRect: Display computeBoundingBox.
    "paint the gray Form on the screen for a while. "
    [Sensor anyButtonPressed] whileFalse:
        [aBitBlt destOrigin: Sensor cursorPoint.
        aBitBlt copyBits]

    "BitBlt exampleTwo"! !


!BitBlt class methodsFor: 'private'!
exampleAt: originPoint rule: rule fillColor: mask
    "This builds a source and destination form and copies the source to the
    destination using the specifed rule and mask. It is called from the method
    named exampleOne."

    | s d border aBitBlt |
    border_Form extent: 32@32.
    border fillBlack.
    border fill: (1@1 extent: 30@30) fillColor: Color white.
    s _ Form extent: 32@32.
    s fillWhite.
    s fillBlack: (7@7 corner: 25@25).
    d _ Form extent: 32@32.
    d fillWhite.
    d fillBlack: (0@0 corner: 32@16).

    s displayOn: Display at: originPoint.
    border displayOn: Display at: originPoint rule: Form under.
    d displayOn: Display at: originPoint + (s width @0).
    border displayOn: Display at: originPoint + (s width @0) rule: Form under.

    d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
    aBitBlt _ BitBlt
        destForm: Display
        sourceForm: s
        fillColor: mask
        combinationRule: rule
        destOrigin: originPoint + (s extent // (2 @ 1))
        sourceOrigin: 0 @ 0
        extent: s extent
        clipRect: Display computeBoundingBox.
    aBitBlt copyBits.
    border
        displayOn: Display at: originPoint + (s extent // (2 @ 1))
        rule: Form under.

    "BitBlt exampleAt: 100@100 rule: Form over fillColor: Display gray"! !
Object subclass: #BitBltSimulation
    instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight sourceBits sourceRaster sourcePixSize destBits destRaster destPixSize pixPerWord bitCount skew mask1 mask2 preload nWords hDir vDir sourceIndex sourceDelta destIndex destDelta sx sy dx dy bbW bbH srcWidth srcHeight halftoneHeight noSource noHalftone halftoneBase colorMap cmBitsPerColor srcBitIndex scanStart scanStop scanString scanRightX scanStopArray scanDisplayFlag scanXTable stopCode bitBltOop affectedL affectedR affectedT affectedB interpreterProxy opTable '
    classVariableNames: 'AllOnes BBClipHeightIndex BBClipWidthIndex BBClipXIndex BBClipYIndex BBColorMapIndex BBDestFormIndex BBDestXIndex BBDestYIndex BBHalftoneFormIndex BBHeightIndex BBLastIndex BBRuleIndex BBSourceFormIndex BBSourceXIndex BBSourceYIndex BBWarpBase BBWidthIndex BBXTableIndex BinaryPoint CrossedX EndOfRun FixedPt1 FormBitsIndex FormDepthIndex FormHeightIndex FormWidthIndex OpTable OpTableSize '
    poolDictionaries: ''
    category: 'Squeak-Interpreter'!
!BitBltSimulation commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitBltSimulation comment:
'This class implements BitBlt, much as specified in the Blue Book spec.

Performance has been enhanced through the use of pointer variables such as sourceIndex and destIndex, and by separating several special cases of the inner loop.

Operation has been extended to color, with support for 1, 2, 4, 8, 16, and 32-bit pixel sizes.  Conversion between different pixel sizes is facilitated by accepting an optional color map.

In addition to the original 16 combination rules, this BitBlt supports
    16    fail (to simulate paint)
    17    fail (to simulate mask)
    18    sourceWord + destinationWord
    19    sourceWord - destinationWord
    20    rgbAdd: sourceWord with: destinationWord
    21    rgbSub: sourceWord with: destinationWord
    22    rgbDiff: sourceWord with: destinationWord
    23    tallyIntoMap: destinationWord
    24    alphaBlend: sourceWord with: destinationWord
    25    pixPaint: sourceWord with: destinationWord
    26    pixMask: sourceWord with: destinationWord
    27    rgbMax: sourceWord with: destinationWord
    28    rgbMin: sourceWord with: destinationWord
    29    rgbMin: sourceWord bitInvert32 with: destinationWord

This implementation has also been fitted with an experimental "warp drive" that allows abritrary scaling and rotation (and even limited affine deformations) with all BitBlt storage modes supported.
'!


!BitBltSimulation methodsFor: 'interpreter interface'!
drawLoopX: xDelta Y: yDelta
    "This is the primitive implementation of the line-drawing loop.
    See the comments in BitBlt>>drawLoopX:Y:"
    | dx1 dy1 px py P affL affR affT affB |
    xDelta > 0
        ifTrue: [dx1 _ 1]
        ifFalse: [xDelta = 0
                ifTrue: [dx1 _ 0]
                ifFalse: [dx1 _ -1]].
    yDelta > 0
        ifTrue: [dy1 _ 1]
        ifFalse: [yDelta = 0
                ifTrue: [dy1 _ 0]
                ifFalse: [dy1 _ -1]].
    px _ yDelta abs.
    py _ xDelta abs.
    affL _ affT _ 9999.  "init null rectangle"
    affR _ affB _ -9999.
    py > px
        ifTrue:
            ["more horizontal"
            P _ py // 2.
            1 to: py do:
                [:i |
                destX _ destX + dx1.
                (P _ P - px) < 0 ifTrue:
                    [destY _ destY + dy1.
                    P _ P + py].
                i < py ifTrue:
                    [self copyBits.
                    (affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
                        ["Affected rectangle grows along the line"
                        affL _ affL min: affectedL.
                        affR _ affR max: affectedR.
                        affT _ affT min: affectedT.
                        affB _ affB max: affectedB.
                        (affR - affL) * (affB - affT) > 4000 ifTrue:
                            ["If affected rectangle gets large, update it in chunks"
                            affectedL _ affL.  affectedR _ affR.
                            affectedT _ affT.  affectedB _ affB.
                            interpreterProxy showDisplayBits.
                            affL _ affT _ 9999.  "init null rectangle"
                            affR _ affB _ -9999]].
                    ]]]
        ifFalse:
            ["more vertical"
            P _ px // 2.
            1 to: px do:
                [:i |
                destY _ destY + dy1.
                (P _ P - py) < 0 ifTrue:
                    [destX _ destX + dx1.
                    P _ P + px].
                i < px ifTrue:
                    [self copyBits.
                    (affectedL < affectedR and: [affectedT < affectedB]) ifTrue:
                        ["Affected rectangle grows along the line"
                        affL _ affL min: affectedL.
                        affR _ affR max: affectedR.
                        affT _ affT min: affectedT.
                        affB _ affB max: affectedB.
                        (affR - affL) * (affB - affT) > 4000 ifTrue:
                            ["If affected rectangle gets large, update it in chunks"
                            affectedL _ affL.  affectedR _ affR.
                            affectedT _ affT.  affectedB _ affB.
                            interpreterProxy showDisplayBits.
                            affL _ affT _ 9999.  "init null rectangle"
                            affR _ affB _ -9999]].
                    ]]].

    "Remaining affected rect"
    affectedL _ affL.  affectedR _ affR.
    affectedT _ affT.  affectedB _ affB.

    "store destX, Y back"
    interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
    interpreterProxy storeInteger: BBDestYIndex ofObject: bitBltOop withValue: destY.! !

!BitBltSimulation methodsFor: 'interpreter interface'!
loadBitBltFrom: bbObj
    "Load context from BitBlt instance.  Return false if anything is amiss"
    "NOTE this should all be changed to minX/maxX coordinates for simpler clipping
        -- once it works!!"
    | destBitsSize destWidth destHeight sourceBitsSize sourcePixPerWord cmSize halftoneBits |
    bitBltOop _ bbObj.
    combinationRule _ interpreterProxy fetchInteger: BBRuleIndex ofObject: bitBltOop.
    (interpreterProxy failed
        or: [combinationRule < 0 or: [combinationRule > 29]])
         ifTrue: [^ false  "operation out of range"].
    (combinationRule >= 16 and: [combinationRule <= 17])
         ifTrue: [^ false  "fail for old simulated paint, erase modes"].
    sourceForm _ interpreterProxy fetchPointer: BBSourceFormIndex ofObject: bitBltOop.
    noSource _ self ignoreSourceOrHalftone: sourceForm.
    halftoneForm _ interpreterProxy fetchPointer: BBHalftoneFormIndex ofObject: bitBltOop.
    noHalftone _ self ignoreSourceOrHalftone: halftoneForm.

    destForm _ interpreterProxy fetchPointer: BBDestFormIndex ofObject: bitBltOop.
        ((interpreterProxy isPointers: destForm) and: [(interpreterProxy lengthOf: destForm) >= 4])
            ifFalse: [^ false].
        destBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: destForm.
        destBitsSize _ interpreterProxy byteLengthOf: destBits.
        destWidth _ interpreterProxy fetchInteger: FormWidthIndex ofObject: destForm.
        destHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: destForm.
        (destWidth >= 0 and: [destHeight >= 0])
            ifFalse: [^ false].
        destPixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: destForm.
        pixPerWord _ 32 // destPixSize.
        destRaster _ destWidth + (pixPerWord-1) // pixPerWord.
        ((interpreterProxy isWordsOrBytes: destBits)
            and: [destBitsSize = (destRaster * destHeight * 4)])
            ifFalse: [^ false].
    destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bitBltOop.
    destY _ interpreterProxy fetchIntegerOrTruncFloat: BBDestYIndex ofObject: bitBltOop.
    width _ interpreterProxy fetchIntegerOrTruncFloat: BBWidthIndex ofObject: bitBltOop.
    height _ interpreterProxy fetchIntegerOrTruncFloat: BBHeightIndex ofObject: bitBltOop.
        interpreterProxy failed ifTrue: [^ false  "non-integer value"].

    noSource ifTrue:
        [sourceX _ sourceY _ 0]
        ifFalse:
        [((interpreterProxy isPointers: sourceForm) and: [(interpreterProxy lengthOf: sourceForm) >= 4])
            ifFalse: [^ false].
        sourceBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: sourceForm.
        sourceBitsSize _ interpreterProxy byteLengthOf: sourceBits.
        srcWidth _ interpreterProxy fetchIntegerOrTruncFloat: FormWidthIndex ofObject: sourceForm.
        srcHeight _ interpreterProxy fetchIntegerOrTruncFloat: FormHeightIndex ofObject: sourceForm.
        (srcWidth >= 0 and: [srcHeight >= 0])
            ifFalse: [^ false].
        sourcePixSize _ interpreterProxy fetchInteger: FormDepthIndex ofObject: sourceForm.
        sourcePixPerWord _ 32 // sourcePixSize.
        sourceRaster _ srcWidth + (sourcePixPerWord-1) // sourcePixPerWord.
        ((interpreterProxy isWordsOrBytes: sourceBits)
            and: [sourceBitsSize = (sourceRaster * srcHeight * 4)])
            ifFalse: [^ false].
        colorMap _ interpreterProxy fetchPointer: BBColorMapIndex ofObject: bitBltOop.
        "ColorMap, if not nil, must be longWords, and
        2^N long, where N = sourcePixSize for 1, 2, 4, 8 bits,
        or N = 9, 12, or 15 (3, 4, 5 bits per color) for 16 or 32 bits."
        colorMap = interpreterProxy nilObject ifFalse:
            [(interpreterProxy isWords: colorMap)
            ifTrue:
            [cmSize _ interpreterProxy lengthOf: colorMap.
            cmBitsPerColor _ 0.
            cmSize = 512 ifTrue: [cmBitsPerColor _ 3].
            cmSize = 4096 ifTrue: [cmBitsPerColor _ 4].
            cmSize = 32768 ifTrue: [cmBitsPerColor _ 5].
            interpreterProxy primIndex ~= 147 ifTrue:
                ["WarpBlt has different checks on the color map"
                sourcePixSize <= 8
                ifTrue: [cmSize = (1 << sourcePixSize) ifFalse: [^ false] ]
                ifFalse: [cmBitsPerColor = 0 ifTrue: [^ false] ]]
            ]
            ifFalse: [^ false]].
        sourceX _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceXIndex ofObject: bitBltOop.
        sourceY _ interpreterProxy fetchIntegerOrTruncFloat: BBSourceYIndex ofObject: bitBltOop].

    noHalftone ifFalse:
        [((interpreterProxy isPointers: halftoneForm) and: [(interpreterProxy lengthOf: halftoneForm) >= 4])
        ifTrue:
        ["Old-style 32xN monochrome halftone Forms"
        halftoneBits _ interpreterProxy fetchPointer: FormBitsIndex ofObject: halftoneForm.
        halftoneHeight _ interpreterProxy fetchInteger: FormHeightIndex ofObject: halftoneForm.
        (interpreterProxy isWords: halftoneBits)
            ifFalse: [noHalftone _ true]]
        ifFalse:
        ["New spec accepts, basically, a word array"
        ((interpreterProxy isPointers: halftoneForm) not
            and: [interpreterProxy isWords: halftoneForm])
            ifFalse: [^ false].
        halftoneBits _ halftoneForm.
        halftoneHeight _ interpreterProxy lengthOf: halftoneBits].
    halftoneBase _ halftoneBits + 4].

    clipX _ interpreterProxy fetchIntegerOrTruncFloat: BBClipXIndex ofObject: bitBltOop.
    clipY _ interpreterProxy fetchIntegerOrTruncFloat: BBClipYIndex ofObject: bitBltOop.
    clipWidth _ interpreterProxy fetchIntegerOrTruncFloat: BBClipWidthIndex ofObject: bitBltOop.
    clipHeight _ interpreterProxy fetchIntegerOrTruncFloat: BBClipHeightIndex ofObject: bitBltOop.
        interpreterProxy failed ifTrue: [^ false  "non-integer value"].
    clipX < 0 ifTrue: [clipWidth _ clipWidth + clipX.  clipX _ 0].
    clipY < 0 ifTrue: [clipHeight _ clipHeight + clipY.  clipY _ 0].
    clipX+clipWidth > destWidth ifTrue: [clipWidth _ destWidth - clipX].
    clipY+clipHeight > destHeight ifTrue: [clipHeight _ destHeight - clipY].

    ^ true! !

!BitBltSimulation methodsFor: 'interpreter interface'!
loadScannerFrom: bbObj
    start: start stop: stop string: string rightX: rightX
    stopArray: stopArray displayFlag: displayFlag

    self inline: false.
    "Load arguments and Scanner state"
    scanStart _ start.
    scanStop _ stop.
    scanString _ string.
    scanRightX _ rightX.
    scanStopArray _ stopArray.
    scanDisplayFlag _ displayFlag.
    interpreterProxy success: (
        (interpreterProxy isPointers: scanStopArray)
            and: [(interpreterProxy lengthOf: scanStopArray) >= 1]).
    scanXTable _ interpreterProxy fetchPointer: BBXTableIndex ofObject: bbObj.
    interpreterProxy success: (
        (interpreterProxy isPointers: scanXTable)
            and: [(interpreterProxy lengthOf: scanXTable) >= 1]).

    "width and sourceX may not be set..."
    interpreterProxy storeInteger: BBWidthIndex ofObject: bbObj withValue: 0.
    interpreterProxy storeInteger: BBSourceXIndex ofObject: bbObj withValue: 0.

    "Now load BitBlt state if displaying"
    scanDisplayFlag
        ifTrue: [interpreterProxy success: (self loadBitBltFrom: bbObj)]
        ifFalse: [bitBltOop _ bbObj.
                destX _ interpreterProxy fetchIntegerOrTruncFloat: BBDestXIndex ofObject: bbObj].
    ^interpreterProxy failed not! !

!BitBltSimulation methodsFor: 'interpreter interface'!
scanCharacters

    | left top lastIndex charVal ascii sourceX2 nextDestX |
    scanDisplayFlag ifTrue:
        [self clipRange.  "Need to get true x, y for affectedRectangle"
        left _ dx.
        top _ dy].
    lastIndex _ scanStart.
    [lastIndex <= scanStop]
        whileTrue: [
            charVal _ interpreterProxy stObject: scanString at: lastIndex.
            ascii _ interpreterProxy integerValueOf: charVal.
            interpreterProxy failed ifTrue: [^ nil].
            stopCode _ interpreterProxy stObject: scanStopArray at: ascii + 1.
            interpreterProxy failed ifTrue: [^ nil].
            stopCode = interpreterProxy nilObject
                ifFalse: [^ self returnAt: ascii + 1
                             lastIndex: lastIndex
                                  left: left
                                  top: top].
            sourceX _ interpreterProxy stObject: scanXTable at: ascii + 1.
            sourceX2 _ interpreterProxy stObject: scanXTable at: ascii + 2.
            interpreterProxy failed ifTrue: [^ nil].
            (interpreterProxy isIntegerObject: sourceX) & (interpreterProxy isIntegerObject: sourceX2)
                ifTrue: [sourceX _ interpreterProxy integerValueOf: sourceX.
                        sourceX2 _ interpreterProxy integerValueOf: sourceX2]
                ifFalse: [interpreterProxy primitiveFail. ^ nil].
            nextDestX _ destX + (width _ sourceX2 - sourceX).
            nextDestX > scanRightX
                ifTrue: [^ self returnAt: CrossedX
                             lastIndex: lastIndex
                                  left: left
                                  top: top].
            scanDisplayFlag ifTrue: [self copyBits].
            destX _ nextDestX.
            interpreterProxy storeInteger: BBDestXIndex ofObject: bitBltOop withValue: destX.
            lastIndex _ lastIndex + 1].
    self returnAt: EndOfRun
         lastIndex: scanStop
              left: left
              top: top! !

!BitBltSimulation methodsFor: 'interpreter interface'!
setInterpreter: anInterpreter
    "Interface for InterpreterSimulator. Allows BitBltSimulation object to send messages to the interpreter. The translator will replace sends to 'interpreterProxy' with sends to self, as if BitBltSimulation were part of the interpreter."

    interpreterProxy _ anInterpreter.! !


!BitBltSimulation methodsFor: 'accessing'!
affectedBottom

    ^affectedB! !

!BitBltSimulation methodsFor: 'accessing'!
affectedLeft

    ^affectedL! !

!BitBltSimulation methodsFor: 'accessing'!
affectedRight

    ^affectedR! !

!BitBltSimulation methodsFor: 'accessing'!
affectedTop

    ^affectedT! !

!BitBltSimulation methodsFor: 'accessing'!
stopReason

    ^stopCode! !

!BitBltSimulation methodsFor: 'accessing'!
targetForm
    "Return the destination form of a copyBits or scanCharacters operation."

    ^destForm! !


!BitBltSimulation methodsFor: 'setup'!
checkSourceOverlap
    | t |
    "check for possible overlap of source and destination"
    (sourceForm = destForm and: [dy >= sy]) ifTrue:
        [dy > sy ifTrue:
            ["have to start at bottom"
            vDir _ -1.
            sy _ sy + bbH - 1.
            dy _ dy + bbH - 1]
        ifFalse:
            [dx > sx ifTrue:
                ["y's are equal, but x's are backward"
                hDir _ -1.
                sx _ sx + bbW - 1.
                "start at right"
                dx _ dx + bbW - 1.
                "and fix up masks"
                nWords > 1 ifTrue:
                    [t _ mask1.
                    mask1 _ mask2.
                    mask2 _ t]]].
        "Dest inits may be affected by this change"
        destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).
        destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir))]! !

!BitBltSimulation methodsFor: 'setup'!
clipRange
    "clip and adjust source origin and extent appropriately"
    "first in x"
    destX >= clipX
        ifTrue: [sx _ sourceX.
                dx _ destX.
                bbW _ width]
        ifFalse: [sx _ sourceX + (clipX - destX).
                bbW _ width - (clipX - destX).
                dx _ clipX].
    (dx + bbW) > (clipX + clipWidth)
        ifTrue: [bbW _ bbW - ((dx + bbW) - (clipX + clipWidth))].
    "then in y"
    destY >= clipY
        ifTrue: [sy _ sourceY.
                dy _ destY.
                bbH _ height]
        ifFalse: [sy _ sourceY + clipY - destY.
                bbH _ height - (clipY - destY).
                dy _ clipY].
    (dy + bbH) > (clipY + clipHeight)
        ifTrue: [bbH _ bbH - ((dy + bbH) - (clipY + clipHeight))].
    noSource ifTrue: [^ nil].
    sx < 0
        ifTrue: [dx _ dx - sx.
                bbW _ bbW + sx.
                sx _ 0].
    sx + bbW > srcWidth
        ifTrue: [bbW _ bbW - (sx + bbW - srcWidth)].
    sy < 0
        ifTrue: [dy _ dy - sy.
                bbH _ bbH + sy.
                sy _ 0].
    sy + bbH > srcHeight
        ifTrue: [bbH _ bbH - (sy + bbH - srcHeight)]! !

!BitBltSimulation methodsFor: 'setup'!
copyBits
    self clipRange.
    (bbW <= 0 or: [bbH <= 0]) ifTrue:
        ["zero width or height; noop"
        affectedL _ affectedR _ affectedT _ affectedB _ 0.
        ^ nil].

    self destMaskAndPointerInit.
    bitCount _ 0.
    noSource
        ifTrue: [self copyLoopNoSource]
        ifFalse: [self checkSourceOverlap.
                (sourcePixSize ~= destPixSize
                    or: [colorMap ~= interpreterProxy nilObject])
                    ifTrue: [self copyLoopPixMap]
                    ifFalse: [self sourceSkewAndPointerInit.
                            self copyLoop]].

    combinationRule = 22 ifTrue:
        ["zero width and height; return the count"
        affectedL _ affectedR _ affectedT _ affectedB _ 0.
        interpreterProxy pop: 1.
        ^ interpreterProxy pushInteger: bitCount].

    hDir > 0
        ifTrue: [affectedL _ dx.
                affectedR _ dx + bbW]
        ifFalse: [affectedL _ dx - bbW + 1.
                affectedR _ dx + 1].
    vDir > 0
        ifTrue: [affectedT _ dy.
                affectedB _ dy + bbH]
        ifFalse: [affectedT _ dy - bbH + 1.
                affectedB _ dy + 1]! !

!BitBltSimulation methodsFor: 'setup'!
destMaskAndPointerInit
    "Compute masks for left and right destination words"
    | startBits pixPerM1 endBits |
    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"
    "how many pixels in first word"
    startBits _ pixPerWord - (dx bitAnd: pixPerM1).
    mask1 _ AllOnes >> (32 - (startBits*destPixSize)).
    "how many pixels in last word"
    endBits _ ((dx + bbW - 1) bitAnd: pixPerM1) + 1.
    mask2 _ AllOnes << (32 - (endBits*destPixSize)).
    "determine number of words stored per line; merge masks if only 1"
    bbW < startBits
        ifTrue: [mask1 _ mask1 bitAnd: mask2.
                mask2 _ 0.
                nWords _ 1]
        ifFalse: [nWords _ (bbW - startBits) + pixPerM1 // pixPerWord + 1].
    hDir _ vDir _ 1. "defaults for no overlap with source"

    "calculate byte addr and delta, based on first word of data"
    "Note raster and nwords are longs, not bytes"
    destIndex _ (destBits + 4) + (dy * destRaster + (dx // pixPerWord) *4).
    destDelta _ 4 * ((destRaster * vDir) - (nWords * hDir)).  "byte addr delta"! !

!BitBltSimulation methodsFor: 'setup'!
ignoreSourceOrHalftone: formPointer

    formPointer = interpreterProxy nilObject ifTrue: [ ^true ].
    combinationRule = 0 ifTrue: [ ^true ].
    combinationRule = 5 ifTrue: [ ^true ].
    combinationRule = 10 ifTrue: [ ^true ].
    combinationRule = 15 ifTrue: [ ^true ].
    ^false! !

!BitBltSimulation methodsFor: 'setup'!
returnAt: stopIndex lastIndex: lastIndex left: left top: top

    stopCode _ interpreterProxy stObject: scanStopArray at: stopIndex.
    interpreterProxy failed ifTrue: [^ nil].
    interpreterProxy storeInteger: BBLastIndex ofObject: bitBltOop withValue: lastIndex.
    scanDisplayFlag ifTrue: [
        "Now we know extent of affected rectangle"
        affectedL _ left.
        affectedR _ bbW + dx.
        affectedT _ top.
        affectedB _ bbH + dy.
    ].! !

!BitBltSimulation methodsFor: 'setup'!
sourceSkewAndPointerInit
    "This is only used when source and dest are same depth,
    ie, when the barrel-shift copy loop is used."
    | dWid sxLowBits dxLowBits pixPerM1 |
    pixPerM1 _ pixPerWord - 1.  "A mask, assuming power of two"
    sxLowBits _ sx bitAnd: pixPerM1.
    dxLowBits _ dx bitAnd: pixPerM1.
    "check if need to preload buffer
    (i.e., two words of source needed for first word of destination)"
    hDir > 0 ifTrue:
        ["n Bits stored in 1st word of dest"
        dWid _ bbW min: pixPerWord - dxLowBits.
        preload _ (sxLowBits + dWid) > pixPerM1]
    ifFalse:
        [dWid _ bbW min: dxLowBits + 1.
        preload _ (sxLowBits - dWid + 1) < 0].

    "calculate right-shift skew from source to dest"
    skew _ (sxLowBits - dxLowBits) * destPixSize.  " -32..32 "
    preload ifTrue:
        [skew < 0
            ifTrue: [skew _ skew+32]
            ifFalse: [skew _ skew-32]].

    "Calc byte addr and delta from longWord info"
    sourceIndex _ (sourceBits + 4) + (sy * sourceRaster + (sx // (32//sourcePixSize)) *4).
    "calculate increments from end of 1 line to start of next"
    sourceDelta _ 4 * ((sourceRaster * vDir) - (nWords * hDir)).
    preload ifTrue:
        ["Compensate for extra source word fetched"
        sourceDelta _ sourceDelta - (4*hDir)].! !

!BitBltSimulation methodsFor: 'setup'!
warpBits
    | ns |
    ns _ noSource.  noSource _ true.
        self clipRange.  "noSource suppresses sourceRect clipping"
        noSource _ ns.
    (noSource or: [bbW <= 0 or: [bbH <= 0]]) ifTrue:
        ["zero width or height; noop"
        affectedL _ affectedR _ affectedT _ affectedB _ 0.
        ^ nil].

    self destMaskAndPointerInit.
    self warpLoop.

    hDir > 0
        ifTrue: [affectedL _ dx.
                affectedR _ dx + bbW]
        ifFalse: [affectedL _ dx - bbW + 1.
                affectedR _ dx + 1].
    vDir > 0
        ifTrue: [affectedT _ dy.
                affectedB _ dy + bbH]
        ifFalse: [affectedT _ dy - bbH + 1.
                affectedB _ dy + 1]! !


!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:42'!
copyLoop
    | prevWord thisWord skewWord halftoneWord mergeWord hInc y unskew skewMask notSkewMask mergeFnwith |
    "This version of the inner loop assumes noSource = false."
    self inline: false.
    self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
    mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
    mergeFnwith.  "null ref for compiler"

    hInc _ hDir*4.  "Byte delta"
    "degenerate skew fixed for Sparc. 10/20/96 ikp"
    skew == -32
        ifTrue: [skew _ unskew _ skewMask _ 0]
        ifFalse: [skew < 0
            ifTrue:
                [unskew _ skew+32.
                skewMask _ AllOnes << (0-skew)]
            ifFalse:
                [skew == 0
                    ifTrue:
                        [unskew _ 0.
                        skewMask _ AllOnes]
                    ifFalse:
                        [unskew _ skew-32.
                        skewMask _ AllOnes >> skew]]].
    notSkewMask _ skewMask bitInvert32.
    noHalftone
        ifTrue: [halftoneWord _ AllOnes.  halftoneHeight _ 0]
        ifFalse: [halftoneWord _ interpreterProxy longAt: halftoneBase].
    y _ dy.
    1 to: bbH do: "here is the vertical loop"
        [ :i |
        halftoneHeight > 1 ifTrue:  "Otherwise, its always the same"
            [halftoneWord _ interpreterProxy longAt:
                        (halftoneBase + (y \\ halftoneHeight * 4)).
            y _ y + vDir].
        preload ifTrue:
            ["load the 64-bit shifter"
            prevWord _ interpreterProxy longAt: sourceIndex.
            sourceIndex _ sourceIndex + hInc]
            ifFalse:
            [prevWord _ 0].

    "Note: the horizontal loop has been expanded into three parts for speed:"

            "This first section requires masking of the destination store..."
            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
                            bitOr:  "32-bit rotate"
                        ((thisWord bitAnd: skewMask) bitShift: skew).
            prevWord _ thisWord.
            sourceIndex _ sourceIndex + hInc.
            mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex
                put: ((mask1 bitAnd: mergeWord)
                    bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + hInc.

        "This central horizontal loop requires no store masking"
combinationRule = 3
ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"
            [ :word |
            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
                            bitOr:  "32-bit rotate"
                        ((thisWord bitAnd: skewMask) bitShift: skew).
            prevWord _ thisWord.
            sourceIndex _ sourceIndex + hInc.
            interpreterProxy longAt: destIndex put: (skewWord bitAnd: halftoneWord).
            destIndex _ destIndex + hInc]
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge:"
            [ :word |
            thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
                            bitOr:  "32-bit rotate"
                        ((thisWord bitAnd: skewMask) bitShift: skew).
            prevWord _ thisWord.
            sourceIndex _ sourceIndex + hInc.
            mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex put: mergeWord.
            destIndex _ destIndex + hInc]
].

        "This last section, if used, requires masking of the destination store..."
        nWords > 1 ifTrue:
            [thisWord _ interpreterProxy longAt: sourceIndex.  "pick up next word"
            skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew)
                            bitOr:  "32-bit rotate"
                        ((thisWord bitAnd: skewMask) bitShift: skew).
            prevWord _ thisWord.
            sourceIndex _ sourceIndex + hInc.
            mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex
                put: ((mask2 bitAnd: mergeWord)
                    bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + hInc].

    sourceIndex _ sourceIndex + sourceDelta.
    destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:43'!
copyLoopNoSource
    | halftoneWord mergeWord mergeFnwith |
    "Faster copyLoop when source not used.  hDir and vDir are both
    positive, and perload and skew are unused"

    self inline: false.
    self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
    mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
    mergeFnwith.  "null ref for compiler"

    1 to: bbH do: "here is the vertical loop"
        [ :i |
        noHalftone
            ifTrue: [halftoneWord _ AllOnes]
            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].

    "Note: the horizontal loop has been expanded into three parts for speed:"

            "This first section requires masking of the destination store..."
            mergeWord _ self mergeFn: halftoneWord
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex
                put: ((mask1 bitAnd: mergeWord)
                    bitOr: (mask1 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + 4.

        "This central horizontal loop requires no store masking"
combinationRule = 3
ifTrue: [2 to: nWords-1 do: "Special inner loop for STORE"
            [ :word |
            interpreterProxy longAt: destIndex put: halftoneWord.
            destIndex _ destIndex + 4].
] ifFalse: [2 to: nWords-1 do: "Normal inner loop does merge"
            [ :word |
            mergeWord _ self mergeFn: halftoneWord
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex put: mergeWord.
            destIndex _ destIndex + 4].

].

        "This last section, if used, requires masking of the destination store..."
        nWords > 1 ifTrue:
            [mergeWord _ self mergeFn: halftoneWord
                            with: (interpreterProxy longAt: destIndex).
            interpreterProxy longAt: destIndex
                put: ((mask2 bitAnd: mergeWord)
                    bitOr: (mask2 bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + 4].

    destIndex _ destIndex + destDelta]! !

!BitBltSimulation methodsFor: 'inner loop' stamp: 'di 12/30/97 14:45'!
copyLoopPixMap
    "This version of the inner loop maps source pixels
    to a destination form with different depth.  Because it is already
    unweildy, the loop is not unrolled as in the other versions.
    Preload, skew and skewMask are all overlooked, since pickSourcePixels
    delivers its destination word already properly aligned.
    Note that pickSourcePixels could be copied in-line at the top of
    the horizontal loop, and some of its inits moved out of the loop."

    | skewWord halftoneWord mergeWord destMask srcPixPerWord scrStartBits nSourceIncs startBits endBits sourcePixMask destPixMask nullMap mergeFnwith |

    self inline: false.
    self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
    mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
    mergeFnwith.  "null ref for compiler"

    "Additional inits peculiar to unequal source and dest pix size..."
    srcPixPerWord _ 32//sourcePixSize.
    "Check for degenerate shift values 4/28/97 ar"
    sourcePixSize = 32
        ifTrue: [ sourcePixMask _ -1]
        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].
    destPixSize = 32
        ifTrue: [ destPixMask _ -1]
        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].
    nullMap _ colorMap = interpreterProxy nilObject.
    sourceIndex _ (sourceBits + 4) +
                    (sy * sourceRaster + (sx // srcPixPerWord) *4).
    scrStartBits _ srcPixPerWord - (sx bitAnd: srcPixPerWord-1).
    bbW < scrStartBits
        ifTrue: [nSourceIncs _ 0]
        ifFalse: [nSourceIncs _ (bbW - scrStartBits)//srcPixPerWord + 1].
    sourceDelta _ (sourceRaster - nSourceIncs) * 4.

    "Note following two items were already calculated in destmask setup!!"
    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).
    endBits _ ((dx + bbW - 1) bitAnd: pixPerWord-1) + 1.

    1 to: bbH do: "here is the vertical loop"
        [ :i |
        noHalftone
            ifTrue: [halftoneWord _ AllOnes]
            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].
        srcBitIndex _ (sx bitAnd: srcPixPerWord - 1)*sourcePixSize.
        destMask _ mask1.
        "pick up first word"
        bbW < startBits
            ifTrue: [skewWord _ self pickSourcePixels: bbW nullMap: nullMap
                                    srcMask: sourcePixMask destMask: destPixMask.
                    skewWord _ skewWord   "See note below"
                            bitShift: (startBits - bbW)*destPixSize]
            ifFalse: [skewWord _ self pickSourcePixels: startBits nullMap: nullMap
                                    srcMask: sourcePixMask destMask: destPixMask].

        "Here is the horizontal loop..."
        1 to: nWords do: "here is the inner horizontal loop"
            [ :word |
            mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord)
                            with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).
            interpreterProxy longAt: destIndex
                put: ((destMask bitAnd: mergeWord)
                    bitOr:
                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + 4.
            word >= (nWords - 1) ifTrue:
                [word = nWords ifFalse:
                    ["set mask for last word in this row"
                    destMask _ mask2.
                    skewWord _ self pickSourcePixels: endBits nullMap: nullMap
                                    srcMask: sourcePixMask destMask: destPixMask.
                    skewWord _ skewWord   "See note below"
                            bitShift: (pixPerWord-endBits)*destPixSize]]
                ifFalse:
                ["use fullword mask for inner loop"
                destMask _ AllOnes.
                skewWord _ self pickSourcePixels: pixPerWord nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask]].

    sourceIndex _ sourceIndex + sourceDelta.
    destIndex _ destIndex + destDelta]

"NOTE: in both noted shifts above, we are shifting the right-justified
 output of pickSourcePixels so that it is aligned with the destination word.
  Since it gets masked anyway, we could have just picked more pixels
 (startBits in the first case and destPixSize in the second), and it would
 have been simpler, but it is slower to run the pickSourcePixels loop.
 CopyLoopAlphaHack takes advantage of this to avoid having to shift
 full-words in its alphaSource buffer" ! !

!BitBltSimulation methodsFor: 'inner loop'!
warpLoop
    | skewWord halftoneWord mergeWord destMask startBits
      deltaP12x deltaP12y deltaP43x deltaP43y pAx pAy
      xDelta yDelta pBx pBy smoothingCount sourceMapOop nSteps t |

    "This version of the inner loop traverses an arbirary quadrilateral
    source, thus producing a general affine transformation."

    (interpreterProxy fetchWordLengthOf: bitBltOop) >= (BBWarpBase+12)
        ifFalse: [^ interpreterProxy primitiveFail].
    nSteps _ height-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

    pAx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase ofObject: bitBltOop.
    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+3 ofObject: bitBltOop.
    deltaP12x _ self deltaFrom: pAx to: t nSteps: nSteps.
    deltaP12x < 0 ifTrue: [pAx _ t - (nSteps*deltaP12x)].

    pAy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+1 ofObject: bitBltOop.
    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+4 ofObject: bitBltOop.
    deltaP12y _ self deltaFrom: pAy to: t nSteps: nSteps.
    deltaP12y < 0 ifTrue: [pAy _ t - (nSteps*deltaP12y)].

    pBx _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+9 ofObject: bitBltOop.
    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+6 ofObject: bitBltOop.
    deltaP43x _ self deltaFrom: pBx to: t nSteps: nSteps.
    deltaP43x < 0 ifTrue: [pBx _ t - (nSteps*deltaP43x)].

    pBy _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+10 ofObject: bitBltOop.
    t _ interpreterProxy fetchIntegerOrTruncFloat: BBWarpBase+7 ofObject: bitBltOop.
    deltaP43y _ self deltaFrom: pBy to: t nSteps: nSteps.
    deltaP43y < 0 ifTrue: [pBy _ t - (nSteps*deltaP43y)].

    interpreterProxy failed ifTrue: [^ false].  "ie if non-integers above"
    interpreterProxy argCount = 2
        ifTrue: [smoothingCount _ interpreterProxy stackIntegerValue: 1.
                sourceMapOop _ interpreterProxy stackValue: 0.
                sourceMapOop = interpreterProxy nilObject
                ifTrue: [sourcePixSize < 16 ifTrue:
                    ["color map is required to smooth non-RGB dest"
                    ^ interpreterProxy primitiveFail]]
                ifFalse: [(interpreterProxy fetchWordLengthOf: sourceMapOop)
                            < (1 << sourcePixSize) ifTrue:
                    ["sourceMap must be long enough for sourcePixSize"
                    ^ interpreterProxy primitiveFail]]]
        ifFalse: [smoothingCount _ 1.
                sourceMapOop _ interpreterProxy nilObject].
    startBits _ pixPerWord - (dx bitAnd: pixPerWord-1).
    nSteps _ width-1.  nSteps <= 0 ifTrue: [nSteps _ 1].

    destY to: clipY-1 do:
        [ :i |    "Advance increments if there was clipping in y"
        pAx _ pAx + deltaP12x.
        pAy _ pAy + deltaP12y.
        pBx _ pBx + deltaP43x.
        pBy _ pBy + deltaP43y].

    1 to: bbH do:
        [ :i |        "here is the vertical loop..."
        xDelta _ self deltaFrom: pAx to: pBx nSteps: nSteps.
         xDelta >= 0 ifTrue: [sx _ pAx] ifFalse: [sx _ pBx - (nSteps*xDelta)].
        yDelta _ self deltaFrom: pAy to: pBy nSteps: nSteps.
         yDelta >= 0 ifTrue: [sy _ pAy] ifFalse: [sy _ pBy - (nSteps*yDelta)].

        destX to: clipX-1 do:
            [:word |    "Advance increments if there was clipping in x"
            sx _ sx + xDelta.
            sy _ sy + yDelta].

        noHalftone
            ifTrue: [halftoneWord _ AllOnes]
            ifFalse: [halftoneWord _ interpreterProxy longAt: (halftoneBase + (dy+i-1 \\ halftoneHeight * 4))].
        destMask _ mask1.
        "pick up first word"
        bbW < startBits
            ifTrue: [skewWord _ self warpSourcePixels: bbW
                                    xDeltah: xDelta yDeltah: yDelta
                                    xDeltav: deltaP12x yDeltav: deltaP12y
                                    smoothing: smoothingCount sourceMap: sourceMapOop.
                    skewWord _ skewWord
                            bitShift: (startBits - bbW)*destPixSize]
            ifFalse: [skewWord _ self warpSourcePixels: startBits
                                    xDeltah: xDelta yDeltah: yDelta
                                    xDeltav: deltaP12x yDeltav: deltaP12y
                                    smoothing: smoothingCount sourceMap: sourceMapOop].

        1 to: nWords do:
            [ :word |        "here is the inner horizontal loop..."
            mergeWord _ self merge: (skewWord bitAnd: halftoneWord)
                with: ((interpreterProxy longAt: destIndex) bitAnd: destMask).
            interpreterProxy longAt: destIndex
                put: ((destMask bitAnd: mergeWord)
                    bitOr:
                    (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))).
            destIndex _ destIndex + 4.
            word >= (nWords - 1) ifTrue:
                [word = nWords ifFalse:
                    ["set mask for last word in this row"
                    destMask _ mask2.
                    skewWord _ self warpSourcePixels: pixPerWord
                                    xDeltah: xDelta yDeltah: yDelta
                                    xDeltav: deltaP12x yDeltav: deltaP12y
                                    smoothing: smoothingCount sourceMap: sourceMapOop]]
                ifFalse:
                ["use fullword mask for inner loop"
                destMask _ AllOnes.
                skewWord _ self warpSourcePixels: pixPerWord
                                    xDeltah: xDelta yDeltah: yDelta
                                    xDeltav: deltaP12x yDeltav: deltaP12y
                                    smoothing: smoothingCount sourceMap: sourceMapOop].
            ].
        pAx _ pAx + deltaP12x.
        pAy _ pAy + deltaP12y.
        pBx _ pBx + deltaP43x.
        pBy _ pBy + deltaP43y.
        destIndex _ destIndex + destDelta]! !


!BitBltSimulation methodsFor: 'combination rules'!
addWord: sourceWord with: destinationWord
    ^sourceWord + destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
alphaBlend: sourceWord with: destinationWord
    "Blend sourceWord with destinationWord, assuming both are 32-bit pixels.
    The source is assumed to have 255*alpha in the high 8 bits of each pixel,
    while the high 8 bits of the destinationWord will be ignored.
    The blend produced is alpha*source + (1-alpha)*dest, with
    the computation being performed independently on each color
    component.  The high byte of the result will be 0."
    | alpha unAlpha colorMask result blend shift |
    self inline: false.
    alpha _ sourceWord >> 24.  "High 8 bits of source pixel"
    unAlpha _ 255 - alpha.
    colorMask _ 16rFF.
    result _ 0.
    1 to: 3 do:
        [:i | shift _ (i-1)*8.
        blend _ (((sourceWord>>shift bitAnd: colorMask) * alpha)
                    + ((destinationWord>>shift bitAnd: colorMask) * unAlpha))
                 + 254 // 255 bitAnd: colorMask.
        result _ result bitOr: blend<<shift].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
bitAnd: sourceWord with: destinationWord
    ^sourceWord bitAnd: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitAndInvert: sourceWord with: destinationWord
    ^sourceWord bitAnd: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAnd: sourceWord with: destinationWord
    ^sourceWord bitInvert32 bitAnd: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertAndInvert: sourceWord with: destinationWord
    ^sourceWord bitInvert32 bitAnd: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertDestination: sourceWord with: destinationWord
    ^destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOr: sourceWord with: destinationWord
    ^sourceWord bitInvert32 bitOr: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertOrInvert: sourceWord with: destinationWord
    ^sourceWord bitInvert32 bitOr: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertSource: sourceWord with: destinationWord
    ^sourceWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitInvertXor: sourceWord with: destinationWord
    ^sourceWord bitInvert32 bitXor: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitOr: sourceWord with: destinationWord
    ^sourceWord bitOr: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
bitOrInvert: sourceWord with: destinationWord
    ^sourceWord bitOr: destinationWord bitInvert32! !

!BitBltSimulation methodsFor: 'combination rules'!
bitXor: sourceWord with: destinationWord
    ^sourceWord bitXor: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
clearWord: source with: destination
    ^ 0! !

!BitBltSimulation methodsFor: 'combination rules'!
destinationWord: sourceWord with: destinationWord
    ^destinationWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/30/97 14:46'!
merge: sourceWord with: destinationWord
    | mergeFnwith |
    "Sender warpLoop is too big to include this in-line"
    self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'.
    mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'.
    mergeFnwith.  "null ref for compiler"

    ^ self mergeFn: sourceWord with: destinationWord! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts
    "Add word1 to word2 as nParts partitions of nBits each.
    This is useful for packed pixels, or packed colors"
    | mask sum result |
    mask _ (1 << nBits) - 1.  "partition mask starts at the right"
    result _ 0.
    1 to: nParts do:
        [:i |
        sum _ (word1 bitAnd: mask) + (word2 bitAnd: mask).
        sum <= mask  "result must not carry out of partition"
            ifTrue: [result _ result bitOr: sum]
            ifFalse: [result _ result bitOr: mask].
        mask _ mask << nBits  "slide left to next partition"].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedAND: word1 to: word2 nBits: nBits nPartitions: nParts
    "AND word1 to word2 as nParts partitions of nBits each.
    Any field of word1 not all-ones is treated as all-zeroes.
    Used for erasing, eg, brush shapes prior to ORing in a color"
    | mask result |
    mask _ (1 << nBits) - 1.  "partition mask starts at the right"
    result _ 0.
    1 to: nParts do:
        [:i |
        (word1 bitAnd: mask) = mask
            ifTrue: [result _ result bitOr: (word2 bitAnd: mask)].
        mask _ mask << nBits  "slide left to next partition"].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts
    "Max word1 to word2 as nParts partitions of nBits each"
    | mask result |
    mask _ (1 << nBits) - 1.  "partition mask starts at the right"
    result _ 0.
    1 to: nParts do:
        [:i |
        result _ result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)).
        mask _ mask << nBits  "slide left to next partition"].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts
    "Min word1 to word2 as nParts partitions of nBits each"
    | mask result |
    mask _ (1 << nBits) - 1.  "partition mask starts at the right"
    result _ 0.
    1 to: nParts do:
        [:i |
        result _ result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)).
        mask _ mask << nBits  "slide left to next partition"].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
partitionedSub: word1 from: word2 nBits: nBits nPartitions: nParts
    "Subtract word1 from word2 as nParts partitions of nBits each.
    This is useful for packed pixels, or packed colors"
    | mask result p1 p2 |
    mask _ (1 << nBits) - 1.  "partition mask starts at the right"
    result _ 0.
    1 to: nParts do:
        [:i |
        p1 _ word1 bitAnd: mask.
        p2 _ word2 bitAnd: mask.
        p1 < p2  "result is really abs value of thedifference"
            ifTrue: [result _ result bitOr: p2 - p1]
            ifFalse: [result _ result bitOr: p1 - p2].
        mask _ mask << nBits  "slide left to next partition"].
    ^ result
! !

!BitBltSimulation methodsFor: 'combination rules'!
pixMask: sourceWord with: destinationWord
    self inline: false.
    ^ self partitionedAND: sourceWord bitInvert32 to: destinationWord
                    nBits: destPixSize nPartitions: pixPerWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/27/97 10:39'!
pixPaint: sourceWord with: destinationWord
    self inline: false.
    sourceWord = 0 ifTrue: [^ destinationWord].
    ^ sourceWord bitOr:
        (self partitionedAND: sourceWord bitInvert32 to: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord)! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbAdd: sourceWord with: destinationWord
    self inline: false.
    destPixSize < 16 ifTrue:
        ["Add each pixel separately"
        ^ self partitionedAdd: sourceWord to: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord].
    destPixSize = 16 ifTrue:
        ["Add RGB components of each pixel separately"
        ^ (self partitionedAdd: sourceWord to: destinationWord
                        nBits: 5 nPartitions: 3)
        + ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16
                        nBits: 5 nPartitions: 3) << 16)]
    ifFalse:
        ["Add RGB components of the pixel separately"
        ^ self partitionedAdd: sourceWord to: destinationWord
                        nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbDiff: sourceWord with: destinationWord
    "Subract the pixels in the source and destination, color by color,
    and return the sum of the absolute value of all the differences.
    For non-rgb, XOR the two and return the number of differing pixels.
    Note that the region is not clipped to bit boundaries, but only to the
    nearest (enclosing) word.  This is because copyLoop does not do
    pre-merge masking.  For accurate results, you must subtract the
    values obtained from the left and right fringes."
    | diff pixMask |
    self inline: false.
    destPixSize < 16 ifTrue:
        ["Just xor and count differing bits if not RGB"
        diff _ sourceWord bitXor: destinationWord.
        pixMask _ (1 bitShift: destPixSize) - 1.
        [diff = 0] whileFalse:
            [(diff bitAnd: pixMask) ~= 0 ifTrue: [bitCount _ bitCount + 1].
            diff _ diff >> destPixSize].
        ^ destinationWord "for no effect"].
     destPixSize = 16
        ifTrue:
        [diff _ (self partitionedSub: sourceWord from: destinationWord
                        nBits: 5 nPartitions: 3).
        bitCount _ bitCount + (diff bitAnd: 16r1F)
                            + (diff>>5 bitAnd: 16r1F)
                            + (diff>>10 bitAnd: 16r1F).
        diff _ (self partitionedSub: sourceWord>>16 from: destinationWord>>16
                        nBits: 5 nPartitions: 3).
        bitCount _ bitCount + (diff bitAnd: 16r1F)
                            + (diff>>5 bitAnd: 16r1F)
                            + (diff>>10 bitAnd: 16r1F)]
        ifFalse:
        [diff _ (self partitionedSub: sourceWord from: destinationWord
                        nBits: 8 nPartitions: 3).
        bitCount _ bitCount + (diff bitAnd: 16rFF)
                            + (diff>>8 bitAnd: 16rFF)
                            + (diff>>16 bitAnd: 16rFF)].
    ^ destinationWord  "For no effect on dest"! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbMax: sourceWord with: destinationWord
    self inline: false.
    destPixSize < 16 ifTrue:
        ["Max each pixel separately"
        ^ self partitionedMax: sourceWord with: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord].
    destPixSize = 16 ifTrue:
        ["Max RGB components of each pixel separately"
        ^ (self partitionedMax: sourceWord with: destinationWord
                        nBits: 5 nPartitions: 3)
        + ((self partitionedMax: sourceWord>>16 with: destinationWord>>16
                        nBits: 5 nPartitions: 3) << 16)]
    ifFalse:
        ["Max RGB components of the pixel separately"
        ^ self partitionedMax: sourceWord with: destinationWord
                        nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbMin: sourceWord with: destinationWord
    self inline: false.
    destPixSize < 16 ifTrue:
        ["Min each pixel separately"
        ^ self partitionedMin: sourceWord with: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord].
    destPixSize = 16 ifTrue:
        ["Min RGB components of each pixel separately"
        ^ (self partitionedMin: sourceWord with: destinationWord
                        nBits: 5 nPartitions: 3)
        + ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
                        nBits: 5 nPartitions: 3) << 16)]
    ifFalse:
        ["Min RGB components of the pixel separately"
        ^ self partitionedMin: sourceWord with: destinationWord
                        nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 1/21/98 21:57'!
rgbMinInvert: wordToInvert with: destinationWord
    | sourceWord |
    self inline: false.
    sourceWord _ wordToInvert bitInvert32.
    destPixSize < 16 ifTrue:
        ["Min each pixel separately"
        ^ self partitionedMin: sourceWord with: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord].
    destPixSize = 16 ifTrue:
        ["Min RGB components of each pixel separately"
        ^ (self partitionedMin: sourceWord with: destinationWord
                        nBits: 5 nPartitions: 3)
        + ((self partitionedMin: sourceWord>>16 with: destinationWord>>16
                        nBits: 5 nPartitions: 3) << 16)]
    ifFalse:
        ["Min RGB components of the pixel separately"
        ^ self partitionedMin: sourceWord with: destinationWord
                        nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
rgbSub: sourceWord with: destinationWord
    self inline: false.
    destPixSize < 16 ifTrue:
        ["Sub each pixel separately"
        ^ self partitionedSub: sourceWord from: destinationWord
                        nBits: destPixSize nPartitions: pixPerWord].
    destPixSize = 16 ifTrue:
        ["Sub RGB components of each pixel separately"
        ^ (self partitionedSub: sourceWord from: destinationWord
                        nBits: 5 nPartitions: 3)
        + ((self partitionedSub: sourceWord>>16 from: destinationWord>>16
                        nBits: 5 nPartitions: 3) << 16)]
    ifFalse:
        ["Sub RGB components of the pixel separately"
        ^ self partitionedSub: sourceWord from: destinationWord
                        nBits: 8 nPartitions: 3]! !

!BitBltSimulation methodsFor: 'combination rules'!
sourceWord: sourceWord with: destinationWord
    ^sourceWord! !

!BitBltSimulation methodsFor: 'combination rules'!
subWord: sourceWord with: destinationWord
    ^sourceWord - destinationWord! !

!BitBltSimulation methodsFor: 'combination rules' stamp: 'di 1/21/98 06:31'!
tallyIntoMap: sourceWord with: destinationWord
    "Tally pixels into the color map.  Note that the source should be
    specified = destination, in order for the proper color map checks
    to be performed at setup.
    Note that the region is not clipped to bit boundaries, but only to the
    nearest (enclosing) word.  This is because copyLoop does not do
    pre-merge masking.  For accurate results, you must subtract the
    values obtained from the left and right fringes."
    | mapIndex pixMask shiftWord |
    colorMap = interpreterProxy nilObject
        ifTrue: [^ destinationWord "no op"].
    destPixSize < 16 ifTrue:
        ["loop through all packed pixels."
        pixMask _ (1<<destPixSize) - 1.
        shiftWord _ destinationWord.
        1 to: pixPerWord do:
            [:i |
            mapIndex _ shiftWord bitAnd: pixMask.
            interpreterProxy storeWord: mapIndex ofObject: colorMap
                withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.
            shiftWord _ shiftWord >> destPixSize].
        ^ destinationWord].
    destPixSize = 16 ifTrue:
        ["Two pixels  Tally the right half..."
        mapIndex _ self rgbMap: (destinationWord bitAnd: 16rFFFF) from: 5 to: cmBitsPerColor.
        interpreterProxy storeWord: mapIndex ofObject: colorMap
            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1.
        "... and then left half"
        mapIndex _ self rgbMap: destinationWord>>16 from: 5 to: cmBitsPerColor.
        interpreterProxy storeWord: mapIndex ofObject: colorMap
            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1]
    ifFalse:
        ["Just one pixel."
        mapIndex _ self rgbMap: destinationWord from: 8 to: cmBitsPerColor.
        interpreterProxy storeWord: mapIndex ofObject: colorMap
            withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1].
    ^ destinationWord  "For no effect on dest"! !


!BitBltSimulation methodsFor: 'pixel mapping'!
deltaFrom: x1 to: x2 nSteps: n
    "Utility routine for computing Warp increments."

    x2 > x1
        ifTrue: [^ x2 - x1 + FixedPt1 // (n+1) + 1]
        ifFalse: [x2 = x1 ifTrue: [^ 0].
                ^ 0 - (x1 - x2 + FixedPt1 // (n+1) + 1)]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:45'!
pickSourcePixels: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask
    "This is intended to be expanded in-line; it merely calls the others"
    self inline: true.
    sourcePixSize >= 16 ifTrue:
        [^ self pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask].
    nullMap ifTrue:
        [^ self pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask].
    ^ self pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixels: nPix srcMask: sourcePixMask destMask: destPixMask
    "This version of pickSourcePixels is for sourcePixSize <= 8
        and colorMap notNil"
    "Pick nPix pixels from the source, mapped by the
    color map, and right-justify them in the resulting destWord."
    | sourceWord destWord sourcePix destPix |
    self inline: false.
    sourceWord _ (interpreterProxy longAt: sourceIndex).
    destWord _ 0.
    1 to: nPix do:
        [:i |
        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
                    bitAnd: sourcePixMask.
        "look up sourcePix in colorMap"
        destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask.
        destWord _ (destWord << destPixSize) bitOr: destPix.
        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
            [srcBitIndex _ srcBitIndex - 32.
            sourceIndex _ sourceIndex + 4.
            sourceWord _ interpreterProxy longAt: sourceIndex]].
    ^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixelsNullMap: nPix srcMask: sourcePixMask destMask: destPixMask
    "This version of pickSourcePixels is for colorMap==nil.
        SourcePixelSize is also known to be 8 bits or less."
    "With no color map, pixels are just masked or zero-filled."
    | sourceWord destWord sourcePix |
    self inline: false.
    sourceWord _ (interpreterProxy longAt: sourceIndex).
    destWord _ 0.
    1 to: nPix do:
        [:i |
        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
                    bitAnd: sourcePixMask.
        destWord _ (destWord << destPixSize)
                    bitOr: (sourcePix bitAnd: destPixMask).
        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
            [srcBitIndex _ srcBitIndex - 32.
            sourceIndex _ sourceIndex + 4.
            sourceWord _ interpreterProxy longAt: sourceIndex]].
    ^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:46'!
pickSourcePixelsRGB: nPix nullMap: nullMap srcMask: sourcePixMask destMask: destPixMask
    "This version of pickSourcePixels is for sourcePixSize >= 16"
    "Pick nPix pixels from the source, mapped by the
    color map, and right-justify them in the resulting destWord.
    Incoming pixels of 16 or 32 bits are first reduced to cmBitsPerColor.
    With no color map, pixels are just masked or zero-filled or
    if 16- or 32-bit pixels, the r, g, and b are so treated individually."
    | sourceWord destWord sourcePix destPix |
    self inline: false.
    sourceWord _ (interpreterProxy longAt: sourceIndex).
    destWord _ 0.
    1 to: nPix do:
        [:i |
        sourcePix _ sourceWord >> ((32-sourcePixSize) - srcBitIndex)
                    bitAnd: sourcePixMask.
        nullMap
        ifTrue:
            ["Map between RGB pixels"
            sourcePixSize = 16
                ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]
                ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]
        ifFalse:
            ["RGB pixels first get reduced to cmBitsPerColor"
            sourcePixSize = 16
                ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]
                ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor].
            "Then look up sourcePix in colorMap"
            destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask].
        destWord _ (destWord << destPixSize) bitOr: destPix.
        (srcBitIndex _ srcBitIndex + sourcePixSize) > 31 ifTrue:
            [srcBitIndex _ srcBitIndex - 32.
            sourceIndex _ sourceIndex + 4.
            sourceWord _ interpreterProxy longAt: sourceIndex]].
    ^ destWord! !

!BitBltSimulation methodsFor: 'pixel mapping'!
rgbMap: sourcePixel from: nBitsIn to: nBitsOut
    "Convert the given pixel value with nBitsIn bits for each color component to a pixel value with nBitsOut bits for each color component. Typical values for nBitsIn/nBitsOut are 3, 5, or 8."
    | mask d srcPix destPix |
    self inline: true.
    (d _ nBitsOut - nBitsIn) > 0
        ifTrue:
            ["Expand to more bits by zero-fill"
            mask _ (1 << nBitsIn) - 1.  "Transfer mask"
            srcPix _ sourcePixel << d.
            mask _ mask << d.
            destPix _ srcPix bitAnd: mask.
            mask _ mask << nBitsOut.
            srcPix _ srcPix << d.
            ^ destPix + (srcPix bitAnd: mask)
                     + (srcPix << d bitAnd: mask << nBitsOut)]
        ifFalse:
            ["Compress to fewer bits by truncation"
            d = 0 ifTrue: [^ sourcePixel].  "no compression"
            sourcePixel = 0 ifTrue: [^ sourcePixel].  "always map 0 (transparent) to 0"
            d _ nBitsIn - nBitsOut.
            mask _ (1 << nBitsOut) - 1.  "Transfer mask"
            srcPix _ sourcePixel >> d.
            destPix _ srcPix bitAnd: mask.
            mask _ mask << nBitsOut.
            srcPix _ srcPix >> d.
            destPix _ destPix + (srcPix bitAnd: mask)
                    + (srcPix >> d bitAnd: mask << nBitsOut).
            destPix = 0 ifTrue: [^ 1].  "Dont fall into transparent by truncation"
            ^ destPix]! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:07'!
smoothPix: n atXf: xf yf: yf dxh: dxh dyh: dyh dxv: dxv dyv: dyv
    pixPerWord: srcPixPerWord pixelMask: sourcePixMask
    sourceMap: sourceMap
    | sourcePix r g b x y rgb bitsPerColor d nPix maxPix |
    self inline: false.
    r _ g _ b _ 0.  "Separate r, g, b components"
    maxPix _ n*n.
    x _ xf.  y _ yf.
    nPix _ 0.  "actual number of pixels (not clipped and not transparent)"
    0 to: n-1 do:
        [:i |
        0 to: n-1 do:
            [:j |
            sourcePix _ (self sourcePixAtX: x + (dxh*i) + (dxv*j)  >> BinaryPoint
                                    y: y + (dyh*i) + (dyv*j)  >> BinaryPoint
                                    pixPerWord: srcPixPerWord)
                                    bitAnd: sourcePixMask.
            (combinationRule=25 "PAINT" and: [sourcePix = 0]) ifFalse:
            ["If not clipped and not transparent, then tally rgb values"
            nPix _ nPix + 1.
            sourcePixSize < 16
                ifTrue: ["Get 24-bit RGB values from sourcemap table"
                        rgb _ (interpreterProxy fetchWord: sourcePix ofObject: sourceMap) bitAnd: 16rFFFFFF]
                ifFalse: ["Already in RGB format"
                        sourcePixSize = 32
                        ifTrue: [rgb _ sourcePix bitAnd: 16rFFFFFF]
                        ifFalse: ["Note could be faster"
                                rgb _ self rgbMap: sourcePix from: 5 to: 8]].
            r _ r + ((rgb >> 16) bitAnd: 16rFF).
            g _ g + ((rgb >> 8) bitAnd: 16rFF).
            b _ b + (rgb bitAnd: 16rFF).
            ]].
        ].
    (nPix = 0 or: [combinationRule=25 "PAINT" and: [nPix < (maxPix//2)]])
        ifTrue: [^ 0  "All pixels were 0, or most were transparent"].
    colorMap ~= interpreterProxy nilObject
        ifTrue: [bitsPerColor _ cmBitsPerColor]
        ifFalse: [destPixSize = 16 ifTrue: [bitsPerColor _ 5].
                destPixSize = 32 ifTrue: [bitsPerColor _ 8]].
    d _ 8 - bitsPerColor.
    rgb _ ((r // nPix >> d) << (bitsPerColor*2))
        + ((g // nPix >> d) << bitsPerColor)
        + ((b // nPix >> d)).
    rgb = 0 ifTrue: [
        "only generate zero if pixel is really transparent"
        (r + g + b) > 0 ifTrue: [rgb _ 1]].
    colorMap ~= interpreterProxy nilObject
        ifTrue: [^ interpreterProxy fetchWord: rgb ofObject: colorMap]
        ifFalse: [^ rgb]
! !

!BitBltSimulation methodsFor: 'pixel mapping'!
sourcePixAtX: x y: y pixPerWord: srcPixPerWord
    | sourceWord index |
    self inline: true.
    (x < 0 or: [x >= srcWidth]) ifTrue: [^ 0].
    (y < 0 or: [y >= srcHeight]) ifTrue: [^ 0].
    index _ (y * sourceRaster + (x // srcPixPerWord) *4).
                                                "4 = BaseHeaderSize"
    sourceWord _ interpreterProxy longAt: sourceBits + 4 + index.
    ^ sourceWord >> ((32-sourcePixSize) - (x\\srcPixPerWord*sourcePixSize))! !

!BitBltSimulation methodsFor: 'pixel mapping' stamp: 'di 12/30/97 20:10'!
warpSourcePixels: nPix xDeltah: xDeltah yDeltah: yDeltah
    xDeltav: xDeltav yDeltav: yDeltav
    smoothing: n sourceMap: sourceMapOop
    "Pick nPix pixels using these x- and y-incs, and map color if necess."

    | destWord sourcePix sourcePixMask destPixMask srcPixPerWord destPix |
    self inline: false.
    sourcePixSize = 32
        ifTrue: [ sourcePixMask _ -1]
        ifFalse: [ sourcePixMask _ (1 << sourcePixSize) - 1].
    destPixSize = 32
        ifTrue: [ destPixMask _ -1]
        ifFalse: [ destPixMask _ (1 << destPixSize) - 1].
    srcPixPerWord _ 32 // sourcePixSize.
    destWord _ 0.
    1 to: nPix do:
        [:i |
        n > 1
        ifTrue:
            ["Average n pixels and compute dest pixel from color map"
            destPix _ (self smoothPix: n atXf: sx yf: sy
                dxh: xDeltah//n dyh: yDeltah//n dxv: xDeltav//n dyv: yDeltav//n
                pixPerWord: srcPixPerWord pixelMask: sourcePixMask
                sourceMap: sourceMapOop)
                    bitAnd: destPixMask]
        ifFalse:
            ["No smoothing -- just pick pixel and map if difft depths or color map supplied"
            sourcePix _ (self sourcePixAtX: sx >> BinaryPoint
                                    y: sy >> BinaryPoint
                                    pixPerWord: srcPixPerWord)
                        bitAnd: sourcePixMask.
            colorMap = interpreterProxy nilObject
                ifTrue:
                [destPixSize = sourcePixSize
                ifTrue:
                    [destPix _ sourcePix]
                ifFalse:
                    [sourcePixSize >= 16 ifTrue:
                        ["Map between RGB pixels"
                        sourcePixSize = 16
                            ifTrue: [destPix _ self rgbMap: sourcePix from: 5 to: 8]
                            ifFalse: [destPix _ self rgbMap: sourcePix from: 8 to: 5]]
                    ifFalse: [destPix _ sourcePix bitAnd: destPixMask]]]
            ifFalse:
                [sourcePixSize >= 16 ifTrue:
                    ["RGB pixels first get reduced to cmBitsPerColor"
                    sourcePixSize = 16
                        ifTrue: [sourcePix _ self rgbMap: sourcePix from: 5 to: cmBitsPerColor]
                        ifFalse: [sourcePix _ self rgbMap: sourcePix from: 8 to: cmBitsPerColor]].
                "Then look up sourcePix in colorMap"
                destPix _ (interpreterProxy fetchWord: sourcePix ofObject: colorMap) bitAnd: destPixMask]].
        destWord _ (destWord << destPixSize) bitOr: destPix.
        sx _ sx + xDeltah.
        sy _ sy + yDeltah.
        ].
    ^ destWord! !


!BitBltSimulation methodsFor: 'translation support' stamp: 'di 1/21/98 23:01'!
initBBOpTable
    self cCode: 'opTable[0+1] = (int)clearWordwith'.
    self cCode: 'opTable[1+1] = (int)bitAndwith'.
    self cCode: 'opTable[2+1] = (int)bitAndInvertwith'.
    self cCode: 'opTable[3+1] = (int)sourceWordwith'.
    self cCode: 'opTable[4+1] = (int)bitInvertAndwith'.
    self cCode: 'opTable[5+1] = (int)destinationWordwith'.
    self cCode: 'opTable[6+1] = (int)bitXorwith'.
    self cCode: 'opTable[7+1] = (int)bitOrwith'.
    self cCode: 'opTable[8+1] = (int)bitInvertAndInvertwith'.
    self cCode: 'opTable[9+1] = (int)bitInvertXorwith'.
    self cCode: 'opTable[10+1] = (int)bitInvertDestinationwith'.
    self cCode: 'opTable[11+1] = (int)bitOrInvertwith'.
    self cCode: 'opTable[12+1] = (int)bitInvertSourcewith'.
    self cCode: 'opTable[13+1] = (int)bitInvertOrwith'.
    self cCode: 'opTable[14+1] = (int)bitInvertOrInvertwith'.
    self cCode: 'opTable[15+1] = (int)destinationWordwith'.
    self cCode: 'opTable[16+1] = (int)destinationWordwith'.
    self cCode: 'opTable[17+1] = (int)destinationWordwith'.
    self cCode: 'opTable[18+1] = (int)addWordwith'.
    self cCode: 'opTable[19+1] = (int)subWordwith'.
    self cCode: 'opTable[20+1] = (int)rgbAddwith'.
    self cCode: 'opTable[21+1] = (int)rgbSubwith'.
    self cCode: 'opTable[22+1] = (int)rgbDiffwith'.
    self cCode: 'opTable[23+1] = (int)tallyIntoMapwith'.
    self cCode: 'opTable[24+1] = (int)alphaBlendwith'.
    self cCode: 'opTable[25+1] = (int)pixPaintwith'.
    self cCode: 'opTable[26+1] = (int)pixMaskwith'.
    self cCode: 'opTable[27+1] = (int)rgbMaxwith'.
    self cCode: 'opTable[28+1] = (int)rgbMinwith'.
    self cCode: 'opTable[29+1] = (int)rgbMinInvertwith'.
    self cCode: 'opTable[30+1] = (int)destinationWordwith'.
    self cCode: 'opTable[31+1] = (int)destinationWordwith'.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBltSimulation class
    instanceVariableNames: ''!

!BitBltSimulation class methodsFor: 'initialization'!
initialize
    "BitBltSimulation initialize"

    self initializeRuleTable.

    "Mask constants"
    AllOnes _ 16rFFFFFFFF.
    BinaryPoint _ 14.
    FixedPt1 _ 1 << BinaryPoint.  "Value of 1.0 in Warp's fixed-point representation"

    "Indices into stopConditions for scanning"
    EndOfRun _ 257.
    CrossedX _ 258.

    "Form fields"
    FormBitsIndex _ 0.
    FormWidthIndex _ 1.
    FormHeightIndex _ 2.
    FormDepthIndex _ 3.

    "BitBlt fields"
    BBDestFormIndex _ 0.
    BBSourceFormIndex _ 1.
    BBHalftoneFormIndex _ 2.
    BBRuleIndex _ 3.
    BBDestXIndex _ 4.
    BBDestYIndex _ 5.
    BBWidthIndex _ 6.
    BBHeightIndex _ 7.
    BBSourceXIndex _ 8.
    BBSourceYIndex _ 9.
    BBClipXIndex _ 10.
    BBClipYIndex _ 11.
    BBClipWidthIndex _ 12.
    BBClipHeightIndex _ 13.
    BBColorMapIndex _ 14.
    BBWarpBase _ 15.
    BBLastIndex _ 15.
    BBXTableIndex _ 16.! !

!BitBltSimulation class methodsFor: 'initialization' stamp: 'di 1/21/98 21:54'!
initializeRuleTable
    "BitBltSimulation initializeRuleTable"
    OpTable _ #(
        "0" clearWord:with:
        "1" bitAnd:with:
        "2" bitAndInvert:with:
        "3" sourceWord:with:
        "4" bitInvertAnd:with:
        "5" destinationWord:with:
        "6" bitXor:with:
        "7" bitOr:with:
        "8" bitInvertAndInvert:with:
        "9" bitInvertXor:with:
        "10" bitInvertDestination:with:
        "11" bitOrInvert:with:
        "12" bitInvertSource:with:
        "13" bitInvertOr:with:
        "14" bitInvertOrInvert:with:
        "15" destinationWord:with:
        "16" destinationWord:with:
        "17" destinationWord:with:
        "18" addWord:with:
        "19" subWord:with:
        "20" rgbAdd:with:
        "21" rgbSub:with:
        "22" rgbDiff:with:
        "23" tallyIntoMap:with:
        "24" alphaBlend:with:
        "25" pixPaint:with:
        "26" pixMask:with:
        "27" rgbMax:with:
        "28" rgbMin:with:
        "29" rgbMinInvert:with:
        "30" destinationWord:with:
        "31" destinationWord:with:
    ).
    OpTableSize _ OpTable size + 1.  "0-origin indexing"
! !

!BitBltSimulation class methodsFor: 'initialization'!
test2  "BitBltSimulation test2"
    | f |
    Display fillWhite: (0@0 extent: 300@140).
    1 to: 12 do:
        [:i | f _ (Form extent: i@5) fillBlack.
        0 to: 20 do:
            [:x | f displayOn: Display
                    at: (x*13) @ (i*10)]]! !

!BitBltSimulation class methodsFor: 'initialization'!
timingTest: extent  "BitBltSimulation timingTest: 640@480"
    | f f2 map |
    f _ Form extent: extent depth: 8.
    f2 _ Form extent: extent depth: 8.
    map _ Bitmap new: 1 << f2 depth.
    ^ Array with:
    (Time millisecondsToRun: [100 timesRepeat:
        [f fillWithColor: Color white]])
    with:
    (Time millisecondsToRun: [100 timesRepeat:
        [f copy: f boundingBox from: 0@0 in: f2 rule: Form over]])
    with:
    (Time millisecondsToRun: [100 timesRepeat:
        [f copyBits: f boundingBox from: f2 at: 0@0 colorMap: map]])! !


!BitBltSimulation class methodsFor: 'translation' stamp: 'di 12/29/97 20:00'!
declareCVarsIn: aCCodeGenerator
    aCCodeGenerator var: 'opTable'
        declareC: 'int opTable[' , OpTableSize printString , ']'! !
BitBltSimulation subclass: #BitBltSimulator
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Squeak-Interpreter'!

!BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 09:23'!
initBBOpTable
    opTable _ OpTable! !

!BitBltSimulator methodsFor: 'all' stamp: 'di 12/30/97 11:07'!
mergeFn: arg1 with: arg2
    ^ self perform: (opTable at: combinationRule+1) with: arg1 with: arg2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBltSimulator class
    instanceVariableNames: ''!

!BitBltSimulator class methodsFor: 'translation' stamp: 'ikp 1/3/98 23:10'!
translate: fileName doInlining: inlineFlag
    "Time millisecondsToRun: [
        Interpreter translate: 'interp.c' doInlining: true.
        Smalltalk beep] 164760 167543 171826 174510"
    | cg |
    BitBltSimulation initialize.
    Interpreter initialize.
    ObjectMemory initialize.
    cg _ CCodeGenerator new initialize.
    cg addClass: BitBltSimulation.
    cg addClass: Interpreter.
    cg addClass: ObjectMemory.
    BitBltSimulation declareCVarsIn: cg.
    Interpreter declareCVarsIn: cg.
    ObjectMemory declareCVarsIn: cg.
    cg storeCodeOnFile: fileName doInlining: inlineFlag.! !
MouseMenuController subclass: #BitEditor
    instanceVariableNames: 'scale squareForm color transparent '
    classVariableNames: 'ColorButtons YellowButtonMenu YellowButtonMessages '
    poolDictionaries: ''
    category: 'Graphics-Editors'!
!BitEditor commentStamp: 'di 5/22/1998 16:32' prior: 0!
BitEditor comment:
'I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.'!


!BitEditor methodsFor: 'initialize-release'!
initialize

    super initialize.
    self initializeYellowButtonMenu! !

!BitEditor methodsFor: 'initialize-release'!
release

    super release.
    squareForm release.
    squareForm _ nil! !


!BitEditor methodsFor: 'view access'!
view: aView

    super view: aView.
    scale _ aView transformation scale.
    scale _ scale x rounded @ scale y rounded.
    squareForm _ Form extent: scale depth: aView model depth.
    squareForm fillBlack! !


!BitEditor methodsFor: 'basic control sequence'!
controlInitialize

    super controlInitialize.
    Cursor crossHair show! !

!BitEditor methodsFor: 'basic control sequence'!
controlTerminate

    Cursor normal show! !


!BitEditor methodsFor: 'control defaults'!
isControlActive

    ^super isControlActive & sensor blueButtonPressed not
        & sensor keyboardPressed not! !

!BitEditor methodsFor: 'control defaults'!
redButtonActivity
    | formPoint displayPoint |
    model depth = 1 ifTrue:
        ["If this is just a black&white form, then set the color to be
        the opposite of what it was where the mouse was clicked"
        formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
        color _ 1-(view workingForm pixelValueAt: formPoint).
        squareForm fillColor: (color=1 ifTrue: [Color black] ifFalse: [Color white])].
    [sensor redButtonPressed]
      whileTrue:
        [formPoint _ (view inverseDisplayTransform: sensor cursorPoint - (scale//2)) rounded.
        displayPoint _ view displayTransform: formPoint.
        squareForm
            displayOn: Display
            at: displayPoint
            clippingBox: view insetDisplayBox
            rule: Form over
            fillColor: nil.
        view changeValueAt: formPoint put: color]! !


!BitEditor methodsFor: 'menu messages'!
accept
    "The edited information should now be accepted by the view."

    view accept! !

!BitEditor methodsFor: 'menu messages'!
cancel
    "The edited informatin should be forgotten by the view."

    view cancel! !

!BitEditor methodsFor: 'menu messages' stamp: 'jm 3/27/98 14:52'!
fileOut

    | fileName |
    fileName _ FillInTheBlank
        request: 'File name?'
        initialAnswer: 'Filename.form'.
    fileName isEmpty ifTrue: [^ self].
    Cursor normal
        showWhile: [model writeOnFileNamed: fileName].
! !

!BitEditor methodsFor: 'menu messages'!
setColor: aColor
    "Set the color that the next edited dots of the model to be the argument,
    aSymbol. aSymbol can be any color changing message understood by a
    Form, such as white or black."

    color _ aColor pixelValueForDepth: model depth.
    squareForm fillColor: aColor.
! !

!BitEditor methodsFor: 'menu messages'!
setTransparentColor
    squareForm fillColor: Color gray.
    color _ model transparentPixelValue! !

!BitEditor methodsFor: 'menu messages'!
test
    view workingForm follow: [Sensor cursorPoint] while: [Sensor noButtonPressed].
    Sensor waitNoButton! !


!BitEditor methodsFor: 'private'!
initializeYellowButtonMenu

    self yellowButtonMenu: YellowButtonMenu
        yellowButtonMessages: YellowButtonMessages! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitEditor class
    instanceVariableNames: ''!

!BitEditor class methodsFor: 'class initialization'!
initialize
    "The Bit Editor is the only controller to override the use of the blue
    button with a different pop-up menu. Initialize this menu."

    YellowButtonMenu _ PopUpMenu labels:
'cancel
accept
file out
test' lines: #(2 3).
    YellowButtonMessages _ #(cancel accept fileOut test)

    "BitEditor initialize"! !


!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm
    "Create and schedule a BitEditor on the form aForm at its top left corner.
    Show the small and magnified view of aForm."

    | scaleFactor |
    scaleFactor _ 8 @ 8.
    ^self openOnForm: aForm
        at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft
        scale: scaleFactor! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation
    "Create and schedule a BitEditor on the form aForm at magnifiedLocation.
    Show the small and magnified view of aForm."

    ^self openOnForm: aForm
        at: magnifiedLocation
        scale: 8 @ 8! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm at: magnifiedLocation scale: scaleFactor
    "Create and schedule a BitEditor on the form aForm. Show the small and
    magnified view of aForm."

    | aScheduledView |
    aScheduledView _ self
                bitEdit: aForm
                at: magnifiedLocation
                scale: scaleFactor
                remoteView: nil.
    aScheduledView controller openDisplayAt:
        aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)! !

!BitEditor class methodsFor: 'instance creation'!
openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor
    "Create and schedule a BitEditor on the form aForm. Show the magnified
    view of aForm in a scheduled window."
    | smallFormView bitEditor savedForm r |
    smallFormView _ FormView new model: aForm.
    smallFormView align: smallFormView viewport topLeft with: formLocation.
    bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView.
    bitEditor controller blueButtonMenu: nil blueButtonMessages: nil.
    savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).
    bitEditor controller startUp.
    savedForm displayOn: Display at: r topLeft.
    bitEditor release.
    smallFormView release.

    "BitEditor magnifyOnScreen."! !


!BitEditor class methodsFor: 'examples'!
magnifyOnScreen
    "Bit editing of an area of the display screen. User designates a
    rectangular area that is magnified by 8 to allow individual screens dots to
    be modified. red button is used to set a bit to black and yellow button is
    used to set a bit to white. Editor is not scheduled in a view. Original
    screen location is updated immediately. This is the same as FormEditor
    magnify."
    | smallRect smallForm scaleFactor tempRect |
    scaleFactor _ 8 @ 8.
    smallRect _ Rectangle fromUser.
    smallRect isNil ifTrue: [^self].
    smallForm _ Form fromDisplay: smallRect.
    tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor.
    "show magnified form size until mouse is depressed"
    self
        openScreenViewOnForm: smallForm
        at: smallRect topLeft
        magnifiedAt: tempRect topLeft
        scale: scaleFactor

    "BitEditor magnifyOnScreen."! !

!BitEditor class methodsFor: 'examples'!
magnifyWithSmall
"    Also try:
    BitEditor openOnForm:
        (Form extent: 32@32 depth: Display depth)
    BitEditor openOnForm:
        ((MaskedForm extent: 32@32 depth: Display depth)
        withTransparentPixelValue: -1)
"
    "Open a BitEditor viewing an area on the screen which the user chooses"
    | area form |
    area _ Rectangle fromUser.
    area isNil ifTrue: [^ self].
    form _ Form fromDisplay: area.
    self openOnForm: form

    "BitEditor magnifyWithSmall."! !


!BitEditor class methodsFor: 'private' stamp: 'di 1/16/98 15:46'!
bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView
    "Create a BitEditor on aForm. That is, aForm is a small image that will
    change as a result of the BitEditor changing a second and magnified
    view of me. magnifiedFormLocation is where the magnified form is to be
    located on the screen. scaleFactor is the amount of magnification. This
    method implements a scheduled view containing both a small and
    magnified view of aForm. Upon accept, aForm is updated."

    | aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent |
    scaledFormView _ FormHolderView new model: aForm.
    scaledFormView scaleBy: scaleFactor.
    bitEditor _ self new.
    scaledFormView controller: bitEditor.
    bitEditor setColor: Color black.
    topView _ StandardSystemView new.
    remoteView == nil ifTrue: [topView label: 'Bit Editor'].
    topView borderWidth: 2.

    topView addSubView: scaledFormView.
    remoteView == nil
        ifTrue:  "If no remote view, then provide a local view of the form"
            [aFormView _ FormView new model: scaledFormView workingForm.
            aFormView controller: NoController new.
            aForm height < 50
                ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2]
                ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0].
            topView addSubView: aFormView below: scaledFormView]
         ifFalse:  "Otherwise, the remote one should view the same form"
            [remoteView model: scaledFormView workingForm].
    lowerRightExtent _ remoteView == nil
            ifTrue:
                [(scaledFormView viewport width - aFormView viewport width) @
                    (aFormView viewport height max: 50)]
            ifFalse:
                [scaledFormView viewport width @ 50].
    menuView _ self buildColorMenu: lowerRightExtent colorCount: 1.
    menuView model: bitEditor.
    menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0.
    topView
        addSubView: menuView
        align: menuView viewport topRight
        with: scaledFormView viewport bottomRight.
    extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y)
            + (4 @ 4).  "+4 for borders"
    topView minimumSize: extent.
    topView maximumSize: extent.
    topView translateBy: magnifiedFormLocation.
    topView insideColor: Color white.
    ^topView! !

!BitEditor class methodsFor: 'private' stamp: 'jm 4/7/98 20:43'!
buildColorMenu: extent colorCount: nColors
    "See BitEditor magnifyWithSmall."

    | menuView form aSwitchView
     button formExtent highlightForm color leftOffset |
    menuView _ FormMenuView new.
    menuView window: (0@0 corner: extent).
    formExtent _ 30@30 min: extent//(nColors*2+1@2).  "compute this better"
    leftOffset _ extent x-(nColors*2-1*formExtent x)//2.
    highlightForm _ Form extent: formExtent.
    highlightForm borderWidth: 4.
    1 to: nColors do: [:index |
        color _ (nColors = 1
            ifTrue: [#(black)]
            ifFalse: [#(black gray)]) at: index.
        form _ Form extent: formExtent.
        form fill: form boundingBox fillColor: (Color perform: color).
        form borderWidth: 5.
        form border: form boundingBox width: 4 fillColor: Color white.
        button _ Button new.
        index = 1
            ifTrue: [button onAction: [menuView model setColor: Color fromUser]]
            ifFalse: [button onAction: [menuView model setTransparentColor]].

        aSwitchView _ PluggableButtonView
            on: button
            getState: #isOn
            action: #turnOn.
        aSwitchView
            shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index);
            label: form;
            window: (0@0 extent: form extent);
            translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2);
            borderWidth: 1.
        menuView addSubView: aSwitchView].
    ^ menuView
! !

!BitEditor class methodsFor: 'private'!
locateMagnifiedView: aForm scale: scaleFactor
    "Answer a rectangle at the location where the scaled view of the form,
    aForm, should be displayed."

    ^ Rectangle originFromUser: (aForm extent * scaleFactor + (0@50)).
    ! !
ArrayedCollection variableWordSubclass: #Bitmap
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Support'!
!Bitmap commentStamp: 'di 5/22/1998 16:32' prior: 0!
Bitmap comment:
'My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.'!


!Bitmap methodsFor: 'initialize-release'!
fromByteStream: aStream
    "Initialize the array of bits by reading integers from the argument,
    aStream."
    aStream nextInto: self! !


!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:03'!
compress: bm toByteArray: ba
    "Store a run-coded compression of the receiver into the byteArray ba,
    and return the last index stored into. ba is assumed to be large enough.
    The encoding is as follows...
        S {N D}*.
        S is the size of the original bitmap, followed by run-coded pairs.
        N is a run-length * 4 + data code.
        D, the data, depends on the data code...
            0    skip N words, D is absent
            1    N words with all 4 bytes = D (1 byte)
            2    N words all = D (4 bytes)
            3    N words follow in D (4N bytes)
        S and N are encoded as follows...
            0-223    0-223
            224-254    (0-30)*256 + next byte (0-7935)
            255        next 4 bytes"
    | size k word j lowByte eqBytes i |
    <primitive: 237>
    self var: #bm declareC: 'int *bm'.
    self var: #ba declareC: 'unsigned char *ba'.
    size _ bm size.
    i _ self encodeInt: size in: ba at: 1.
    k _ 1.
    [k <= size] whileTrue:
        [word _ bm at: k.
        lowByte _ word bitAnd: 16rFF.
        eqBytes _ ((word >> 8) bitAnd: 16rFF) = lowByte
                and: [((word >> 16) bitAnd: 16rFF) = lowByte
                and: [((word >> 24) bitAnd: 16rFF) = lowByte]].
        j _ k.
        [j < size and: [word = (bm at: j+1)]]  "scan for = words..."
            whileTrue: [j _ j+1].
        j > k ifTrue:
            ["We have two or more = words, ending at j"
            eqBytes
                ifTrue: ["Actually words of = bytes"
                        i _ self encodeInt: j-k+1*4+1 in: ba at: i.
                        ba at: i put: lowByte.  i _ i+1]
                ifFalse: [i _ self encodeInt: j-k+1*4+2 in: ba at: i.
                        i _ self encodeBytesOf: word in: ba at: i].
            k _ j+1]
            ifFalse:
            ["Check for word of 4 = bytes"
            eqBytes ifTrue:
                ["Note 1 word of 4 = bytes"
                i _ self encodeInt: 1*4+1 in: ba at: i.
                ba at: i put: lowByte.  i _ i+1.
                k _ k + 1]
                ifFalse:
                ["Finally, check for junk"
                [j < size and: [(bm at: j) ~= (bm at: j+1)]]  "scan for ~= words..."
                    whileTrue: [j _ j+1].
                j = size ifTrue: [j _ j + 1].
                "We have one or more unmatching words, ending at j-1"
                i _ self encodeInt: j-k*4+3 in: ba at: i.
                k to: j-1 do:
                    [:m | i _ self encodeBytesOf: (bm at: m) in: ba at: i].
                k _ j]]].
    ^ i - 1  "number of bytes actually stored"
"
Space check:
 | n rawBytes myBytes b |
n _ rawBytes _ myBytes _ 0.
Form allInstancesDo:
    [:f | b _ f bits.
    n _ n + 1.
    rawBytes _ rawBytes + (b size*4).
    myBytes _ myBytes + (b compressToByteArray size)].
Array with: n with: rawBytes with: myBytes
ColorForms: (116 230324 160318 )
Forms: (113 1887808 1325055 )

Integerity check:
Form allInstances do:
    [:f | f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray)
        ifFalse: [self halt]]

Speed test:
MessageTally spyOn: [Form allInstances do:
    [:f | Bitmap decompressFromByteArray: f bits compressToByteArray]]
"! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 16:59'!
compressToByteArray
    "Return a run-coded compression of this bitmap into a byteArray"
    | byteArray lastByte |
    "Without skip codes, it is unlikely that the compressed bitmap will be any larger than was the original.  The run-code cases are...
    N >= 1 words of equal bytes:  4N bytes -> 2 bytes (at worst 4 -> 2)
    N > 1 equal words:  4N bytes -> 5 bytes (at worst 8 -> 5)
    N > 1 unequal words:  4N bytes -> 4N + M, where M is the number of bytes required to encode the run length.

The worst that can happen is that the method begins with unequal words, and than has interspersed occurrences of a word with equal bytes.  Thus we require a run-length at the beginning, and after every interspersed word of equal bytes.  However, each of these saves 2 bytes, so it must be followed by a run of 7936 or more (for which M jumps from 2 to 5) to add any extra overhead.  Therefore the worst case is a series of runs of 7936 or more, with single interspersed words of equal bytes.  At each break we save 2 bytes, but add 5.  Thus the overhead would be no more than 5 + (S//7936*3)."

    byteArray _ ByteArray new: (self size*4) + 5 + (self size//7936*3).
    lastByte _ self compress: self toByteArray: byteArray.
    ^ byteArray copyFrom: 1 to: lastByte! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/19/98 17:13'!
decompress: bm fromByteArray: ba at: index
    "Decompress the body of a byteArray encoded by compressToByteArray (qv)...
    The format is simply a sequence of run-coded pairs, {N D}*.
        N is a run-length * 4 + data code.
        D, the data, depends on the data code...
            0    skip N words, D is absent
                (could be used to skip from one raster line to the next)
            1    N words with all 4 bytes = D (1 byte)
            2    N words all = D (4 bytes)
            3    N words follow in D (4N bytes)
        S and N are encoded as follows (see decodeIntFrom:)...
            0-223    0-223
            224-254    (0-30)*256 + next byte (0-7935)
            255        next 4 bytes"
    "NOTE:  If fed with garbage, this routine could read past the end of ba, but it should fail before writing past the ned of bm."
    | i code n anInt data end k pastEnd |
    <primitive: 234>
    self var: #bm declareC: 'int *bm'.
    self var: #ba declareC: 'unsigned char *ba'.
    i _ index.  "byteArray read index"
    end _ ba size.
    k _ 1.  "bitmap write index"
    pastEnd _ bm size + 1.
    [i <= end] whileTrue:
        ["Decode next run start N"
        anInt _ ba at: i.  i _ i+1.
        anInt <= 223 ifFalse:
            [anInt <= 254
                ifTrue: [anInt _ (anInt-224)*256 + (ba at: i).  i _ i+1]
                ifFalse: [anInt _ 0.
                        1 to: 4 do: [:j | anInt _ (anInt bitShift: 8) + (ba at: i).  i _ i+1]]].
        n _ anInt >> 2.
        (k + n) > pastEnd ifTrue: [^ self primitiveFail].
        code _ anInt bitAnd: 3.
        code = 0 ifTrue: ["skip"].
        code = 1 ifTrue: ["n consecutive words of 4 bytes = the following byte"
                        data _ ba at: i.  i _ i+1.
                        data _ data bitOr: (data bitShift: 8).
                        data _ data bitOr: (data bitShift: 16).
                        1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
        code = 2 ifTrue: ["n consecutive words = 4 following bytes"
                        data _ 0.
                        1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
                        1 to: n do: [:j | bm at: k put: data.  k _ k+1]].
        code = 3 ifTrue: ["n consecutive words from the data..."
                        1 to: n do:
                            [:m | data _ 0.
                            1 to: 4 do: [:j | data _ (data bitShift: 8) bitOr: (ba at: i).  i _ i+1].
                            bm at: k put: data.  k _ k+1]]]! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:27'!
encodeBytesOf: anInt in: ba at: i
    "Copy the integer anInt into byteArray ba at index i, and return the next index"

    self inline: true.
    self var: #ba declareC: 'unsigned char *ba'.
    0 to: 3 do:
        [:j | ba at: i+j put: (anInt >> (3-j*8) bitAnd: 16rFF)].
    ^ i+4! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/12/98 17:32'!
encodeInt: int
    "Encode the integer int as per encodeInt:in:at:, and return it as a ByteArray"
    | byteArray next |
    byteArray _ ByteArray new: 5.
    next _ self encodeInt: int in: byteArray at: 1.
    ^ byteArray copyFrom: 1 to: next - 1
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/15/98 17:26'!
encodeInt: anInt in: ba at: i
    "Encode the integer anInt in byteArray ba at index i, and return the next index.
    The encoding is as follows...
        0-223    0-223
        224-254    (0-30)*256 + next byte (0-7935)
        255        next 4 bytes"

    self inline: true.
    self var: #ba declareC: 'unsigned char *ba'.
    anInt <= 223 ifTrue: [ba at: i put: anInt. ^ i+1].
    anInt <= 7935 ifTrue: [ba at: i put: anInt//256+224. ba at: i+1 put: anInt\\256.  ^ i+2].
    ba at: i put: 255.
    ^ self encodeBytesOf: anInt in: ba at: i+1! !

!Bitmap methodsFor: 'filing' stamp: 'di 2/11/98 21:34'!
readCompressedFrom: strm
    "Decompress an old-style run-coded stream into this bitmap:
        [0 means end of runs]
        [n = 1..127] [(n+3) copies of next byte]
        [n = 128..191] [(n-127) next bytes as is]
        [n = 192..255] [(n-190) copies of next 4 bytes]"
    | n byte out outBuff bytes |
    out _ WriteStream on: (outBuff _ ByteArray new: self size*4).
    [(n _ strm next) > 0] whileTrue:
        [(n between: 1 and: 127) ifTrue:
            [byte _ strm next.
            1 to: n+3 do: [:i | out nextPut: byte]].
        (n between: 128 and: 191) ifTrue:
            [1 to: n-127 do: [:i | out nextPut: strm next]].
        (n between: 192 and: 255) ifTrue:
            [bytes _ (1 to: 4) collect: [:i | strm next].
            1 to: n-190 do: [:i | bytes do: [:b | out nextPut: b]]]].
    out position = outBuff size ifFalse: [self error: 'Decompression size error'].
    "Copy the final byteArray into self"
    self copyFromByteArray: outBuff.! !

!Bitmap methodsFor: 'filing' stamp: 'di 10/2/97 00:02'!
swapBytesFrom: start to: stop
    "Perform a bigEndian/littleEndian byte reversal of my words"
    | hack blt |
    "The implementation is a hack, but fast for large ranges"
    hack _ Form new hackBits: self.
    blt _ (BitBlt toForm: hack) sourceForm: hack.
    blt combinationRule: Form reverse.  "XOR"
    blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1.
    blt sourceX: 0; destX: 3; copyBits.  "Exchange bytes 0 and 3"
    blt sourceX: 3; destX: 0; copyBits.
    blt sourceX: 0; destX: 3; copyBits.
    blt sourceX: 1; destX: 2; copyBits.  "Exchange bytes 1 and 2"
    blt sourceX: 2; destX: 1; copyBits.
    blt sourceX: 1; destX: 2; copyBits.
! !

!Bitmap methodsFor: 'filing' stamp: 'jm 2/18/98 14:19'!
writeOn: aStream
    "Store the array of bits onto the argument, aStream. A leading byte of 16r80 identifies this as compressed by compressToByteArray (qv)."

    | b |
    aStream nextPut: 16r80.
    b _ self compressToByteArray.
    aStream
        nextPutAll: (self encodeInt: b size);
        nextPutAll: b.
! !


!Bitmap methodsFor: 'printing'!
printOn: aStream

    aStream nextPutAll: 'a Bitmap of length '.
    self size printOn: aStream! !


!Bitmap methodsFor: 'accessing'!
bitPatternForDepth: depth
    "The raw call on BitBlt needs a Bitmap to represent this color.  I already am Bitmap like.  I am already adjusted for a specific depth.  Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

    ^ self! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress
    "Extract a byte from a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:.  See Form pixelAt:  7/1/96 tk"
    | lowBits |
    lowBits _ byteAddress - 1 bitAnd: 3.
    ^((self at: byteAddress - 1 - lowBits // 4 + 1)
        bitShift: (lowBits - 3) * 8)
        bitAnd: 16rFF! !

!Bitmap methodsFor: 'accessing'!
byteAt: byteAddress put: byte
    "Insert a byte into a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:put:.  See Form pixelAt:put:  7/1/96 tk"

    | longWord shift lowBits longAddr |
    lowBits _ byteAddress - 1 bitAnd: 3.
    longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1).
    shift _ (3 - lowBits) * 8.
    longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift))
        + (byte bitShift: shift).
    self at: longAddr put: longWord.
    ^ byte! !

!Bitmap methodsFor: 'accessing' stamp: 'di 10/4/97 11:56'!
copyFromByteArray: byteArray
    "This method should work with either byte orderings"
    | long |
    (self size * 4) = byteArray size ifFalse: [self halt].
    1 to: byteArray size by: 4 do:
        [:i | long _ Integer
                byte1: (byteArray at: i+3)
                byte2: (byteArray at: i+2)
                byte3: (byteArray at: i+1)
                byte4: (byteArray at: i).
        self at: i+3//4 put: long]! !

!Bitmap methodsFor: 'accessing' stamp: 'tk 3/15/97'!
pixelValueForDepth: depth
    "Self is being used to represent a single color.  Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32.  Returns an integer.  First pixel only.  "

    ^ (self at: 1) bitAnd: (1 bitShift: depth) - 1! !

!Bitmap methodsFor: 'accessing'!
primFill: aPositiveInteger
    "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays."

    <primitive: 145>
    self errorImproperStore.! !

!Bitmap methodsFor: 'accessing'!
replaceFrom: start to: stop with: replacement startingAt: repStart
    "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
    <primitive: 105>
    super replaceFrom: start to: stop with: replacement startingAt: repStart! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bitmap class
    instanceVariableNames: ''!

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/9/98 16:02'!
decodeIntFrom: s
    "Decode an integer in stream s as follows...
        0-223    0-223
        224-254    (0-30)*256 + next byte (0-7935)
        255        next 4 bytes    "
    | int |
    int _ s next.
    int <= 223 ifTrue: [^ int].
    int <= 254 ifTrue: [^ (int-224)*256 + s next].
    int _ s next.
    1 to: 3 do: [:j | int _ (int bitShift: 8) + s next].
    ^ int! !

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/12/98 14:34'!
decompressFromByteArray: byteArray
    | s bitmap size |
    s _ ReadStream on: byteArray.
    size _ self decodeIntFrom: s.
    bitmap _ self new: size.
    bitmap decompress: bitmap fromByteArray: byteArray at: s position+1.
    ^ bitmap! !

!Bitmap class methodsFor: 'instance creation' stamp: 'di 2/11/98 21:11'!
newFromStream: s
    | len |
    s next = 16r80 ifTrue:
        ["New compressed format"
        len _ self decodeIntFrom: s.
        ^ Bitmap decompressFromByteArray: (s nextInto: (ByteArray new: len))].
    s skip: -1.
    len _ s nextInt32.
    len <= 0
        ifTrue: ["Old compressed format"
                ^ (self new: len negated) readCompressedFrom: s]
        ifFalse: ["Old raw data format"
                ^ s nextInto: (self new: len)]! !
ContextPart variableSubclass: #BlockContext
    instanceVariableNames: 'nargs startpc home '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Methods'!
!BlockContext commentStamp: 'di 5/22/1998 16:32' prior: 0!
BlockContext comment:
'My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.

My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.'!


!BlockContext methodsFor: 'initialize-release'!
home: aContextPart startpc: position nargs: anInteger
    "This is the initialization message. The receiver has been initialized with
    the correct size only."

    home _ aContextPart.
    startpc _ position.
    nargs _ anInteger! !


!BlockContext methodsFor: 'accessing'!
fixTemps
    "Fix the values of the temporary variables used in the block that are
    ordinarily shared with the method in which the block is defined."

    home _ home copy.
    home swapSender: nil! !

!BlockContext methodsFor: 'accessing'!
hasMethodReturn
    "Answer whether the receiver has a return ('^') in its code."

    | method scanner end |
    method _ self method.
    "Determine end of block from long jump preceding it"
    end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
    scanner _ InstructionStream new method: method pc: startpc.
    scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]].
    ^scanner pc <= end! !

!BlockContext methodsFor: 'accessing'!
home
    "Answer the context in which the receiver was defined."

    ^home! !

!BlockContext methodsFor: 'accessing'!
method
    "Answer the compiled method in which the receiver was defined."

    ^home method! !

!BlockContext methodsFor: 'accessing'!
numArgs

    ^nargs! !

!BlockContext methodsFor: 'accessing'!
receiver
    "Refer to the comment in ContextPart|receiver."

    ^home receiver! !

!BlockContext methodsFor: 'accessing'!
tempAt: index
    "Refer to the comment in ContextPart|tempAt:."

    ^home at: index! !

!BlockContext methodsFor: 'accessing'!
tempAt: index put: value
    "Refer to the comment in ContextPart|tempAt:put:."

    ^home at: index put: value! !


!BlockContext methodsFor: 'evaluating' stamp: 'jm 2/19/98 13:19'!
ifError: errorHandlerBlock
    "Evaluate the block represented by the receiver. If an error occurs the given is evaluated with the error message and the receiver as parameters. The error handler block may return a value to be used if the receiver block gets an error. The receiver should not contain an explicit return statement as this would leave an obsolete error handler hanging around."
    "Examples:
        [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?'].
        [1 / 0] ifError: [:err :rcvr |
            'division by 0' = err
                ifTrue: [^ Float inf]
                ifFalse: [self error: err]]
"

    | lastHandler val activeProcess |
    activeProcess _ Processor activeProcess.
    lastHandler _ activeProcess errorHandler.
    activeProcess errorHandler: [:aString :aReceiver |
        activeProcess errorHandler: lastHandler.
        ^ errorHandlerBlock value: aString value: aReceiver].
    val _ self value.
    activeProcess errorHandler: lastHandler.
    ^ val
! !

!BlockContext methodsFor: 'evaluating'!
value
    "Primitive. Evaluate the block represented by the receiver. Fail if the
    block expects any arguments or if the block is already being executed.
    Optional. No Lookup. See Object documentation whatIsAPrimitive."

    <primitive: 81>
    ^self valueWithArguments: #()! !

!BlockContext methodsFor: 'evaluating'!
value: arg
    "Primitive. Evaluate the block represented by the receiver. Fail if the
    block expects other than one argument or if the block is already being
    executed. Optional. No Lookup. See Object documentation
    whatIsAPrimitive."

    <primitive: 81>
    ^self valueWithArguments: (Array with: arg)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 ifError: aBlock
    "Evaluate the block represented by the receiver. If an error occurs aBlock is evaluated
     with the error message and the receiver as parameters. The receiver should not contain
     an explicit return statement as this would leave an obsolete error handler hanging around."

    | lastHandler val activeProcess |
    activeProcess _ Processor activeProcess.
    lastHandler _ activeProcess errorHandler.
    activeProcess errorHandler: [:aString :aReceiver |
        activeProcess errorHandler: lastHandler.
        ^ aBlock value: aString value: aReceiver].
    val _ self value: arg1.
    activeProcess errorHandler: lastHandler.
    ^ val! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2
    "Primitive. Evaluate the block represented by the receiver. Fail if the
    block expects other than two arguments or if the block is already being
    executed. Optional. See Object documentation whatIsAPrimitive."

    <primitive: 81>
    ^self valueWithArguments: (Array with: arg1 with: arg2)! !

!BlockContext methodsFor: 'evaluating'!
value: arg1 value: arg2 value: arg3
    "Primitive. Evaluate the block represented by the receiver. Fail if the
    block expects other than three arguments or if the block is already being
    executed. Optional. See Object documentation whatIsAPrimitive."

    <primitive: 81>
    ^self valueWithArguments:
        (Array
            with: arg1
            with: arg2
            with: arg3)! !

!BlockContext methodsFor: 'evaluating' stamp: 'di 11/30/97 09:19'!
value: arg1 value: arg2 value: arg3 value: arg4
    "Primitive. Evaluate the block represented by the receiver. Fail if the
    block expects other than three arguments or if the block is already being
    executed. Optional. See Object documentation whatIsAPrimitive."

    <primitive: 81>
    ^self valueWithArguments:
        (Array
            with: arg1
            with: arg2
            with: arg3
            with: arg4)! !

!BlockContext methodsFor: 'evaluating'!
valueWithArguments: anArray
    "Primitive. Evaluate the block represented by the receiver. The argument
    is an Array whose elements are the arguments for the block. Fail if the
    length of the Array is not the same as the the number of arguments that
    the block was expecting. Fail if the block is already being executed.
    Essential. See Object documentation whatIsAPrimitive."

    <primitive: 82>
    self numArgs = anArray size
        ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.']
        ifFalse: [self error: 'This block requires ' , self numArgs printString , ' arguments.']! !


!BlockContext methodsFor: 'controlling'!
whileFalse
    "Ordinarily compiled in-line, and therefore not overridable.
    This is in case the message is sent to other than a literal block.
    Evaluate the receiver, as long as its value is false."

    ^ [self value] whileFalse: []! !

!BlockContext methodsFor: 'controlling'!
whileFalse: aBlock
    "Ordinarily compiled in-line, and therefore not overridable.
    This is in case the message is sent to other than a literal block.
    Evaluate the argument, aBlock, as long as the value of the receiver is false."

    ^ [self value] whileFalse: [aBlock value]! !

!BlockContext methodsFor: 'controlling'!
whileTrue
    "Ordinarily compiled in-line, and therefore not overridable.
    This is in case the message is sent to other than a literal block.
    Evaluate the receiver, as long as its value is true."

    ^ [self value] whileTrue: []! !

!BlockContext methodsFor: 'controlling'!
whileTrue: aBlock
    "Ordinarily compiled in-line, and therefore not overridable.
    This is in case the message is sent to other than a literal block.
    Evaluate the argument, aBlock, as long as the value of the receiver is true."

    ^ [self value] whileTrue: [aBlock value]! !


!BlockContext methodsFor: 'scheduling'!
fork
    "Create and schedule a Process running the code in the receiver."

    self newProcess resume! !

!BlockContext methodsFor: 'scheduling'!
forkAt: priority
    "Create and schedule a Process running the code in the receiver. The
    priority of the process is the argument, priority."

    | forkedProcess |
    forkedProcess _ self newProcess.
    forkedProcess priority: priority.
    forkedProcess resume! !

!BlockContext methodsFor: 'scheduling'!
newProcess
    "Answer a Process running the code in the receiver. The process is not
    scheduled."

    ^Process
        forContext:
            [self value.
            Processor terminateActive]
        priority: Processor activePriority! !

!BlockContext methodsFor: 'scheduling'!
newProcessWith: anArray
    "Answer a Process running the code in the receiver. The receiver's block
    arguments are bound to the contents of the argument, anArray. The
    process is not scheduled."

    ^Process
        forContext:
            [self valueWithArguments: anArray.
            Processor terminateActive]
        priority: Processor activePriority! !


!BlockContext methodsFor: 'instruction decoding'!
blockReturnTop
    "Simulate the interpreter's action when a ReturnTopOfStack bytecode is
    encountered in the receiver."

    | save dest |
    save _ home.    "Needed because return code will nil it"
    dest _ self return: self pop to: self sender.
    home _ save.
    sender _ nil.
    ^dest! !


!BlockContext methodsFor: 'printing'!
printOn: aStream

    home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
    aStream nextPutAll: '[] in '.
    super printOn: aStream! !


!BlockContext methodsFor: 'private' stamp: 'tk 4/16/1998 15:38'!
cannotReturn: result
    "The receiver tried to return result to a method context that no longer exists."

    Debugger
        openContext: thisContext
        label: 'Block cannot return'
        contents: thisContext shortStack.
! !

!BlockContext methodsFor: 'private'!
startpc
    "for use by the System Tracer only"

    ^startpc! !

!BlockContext methodsFor: 'private'!
valueError

    self error: 'Incompatible number of args, or already active'! !


!BlockContext methodsFor: 'system simulation'!
pushArgs: args from: sendr
    "Simulates action of the value primitive."

    args size ~= nargs ifTrue: [^self error: 'incorrect number of args'].
    stackp _ 0.
    args do: [:arg | self push: arg].
    sender _ sendr.
    pc _ startpc! !
ParseNode subclass: #BlockNode
    instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!
!BlockNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
BlockNode comment:
'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'!


!BlockNode methodsFor: 'initialize-release'!
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder
    "Compile."

    arguments _ argNodes.
    statements _ statementsCollection size > 0
                ifTrue: [statementsCollection]
                ifFalse: [argNodes size > 0
                        ifTrue: [statementsCollection copyWith: arguments last]
                        ifFalse: [Array with: NodeNil]].
    returns _ returnBool! !

!BlockNode methodsFor: 'initialize-release'!
statements: statementsCollection returns: returnBool
    "Decompile."

    | returnLast |
    returnLast _ returnBool.
    returns _ false.
    statements _
        (statementsCollection size > 1
            and: [(statementsCollection at: statementsCollection size - 1)
                    isReturningIf])
                ifTrue:
                    [returnLast _ false.
                    statementsCollection allButLast]
                ifFalse: [statementsCollection size = 0
                        ifTrue: [Array with: NodeNil]
                        ifFalse: [statementsCollection]].
    arguments _ Array new: 0.
    returnLast ifTrue: [self returnLast]! !


!BlockNode methodsFor: 'accessing'!
arguments: argNodes
    "Decompile."

    arguments _ argNodes! !

!BlockNode methodsFor: 'accessing'!
firstArgument
    ^ arguments first! !

!BlockNode methodsFor: 'accessing'!
numberOfArguments

    ^arguments size! !

!BlockNode methodsFor: 'accessing'!
returnLast

    self returns
        ifFalse:
            [returns _ true.
            statements at: statements size put: statements last asReturnNode]! !

!BlockNode methodsFor: 'accessing'!
returnSelfIfNoOther

    self returns
        ifFalse:
            [statements last == NodeSelf ifFalse: [statements add: NodeSelf].
            self returnLast]! !


!BlockNode methodsFor: 'testing'!
canBeSpecialArgument
    "Can I be an argument of (e.g.) ifTrue:?"

    ^arguments size = 0! !

!BlockNode methodsFor: 'testing'!
isComplex

    ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! !

!BlockNode methodsFor: 'testing'!
isJust: node

    returns ifTrue: [^false].
    ^statements size = 1 and: [statements first == node]! !

!BlockNode methodsFor: 'testing'!
isJustCaseError

    ^ statements size = 1 and:
        [statements first
            isMessage: #caseError
            receiver: [:r | r==NodeSelf]
            arguments: nil]! !

!BlockNode methodsFor: 'testing'!
isQuick
    ^ statements size = 1
        and: [statements first isVariableReference
                or: [statements first isSpecialConstant]]! !

!BlockNode methodsFor: 'testing'!
returns

    ^returns or: [statements last isReturningIf]! !


!BlockNode methodsFor: 'code generation'!
code

    ^statements first code! !

!BlockNode methodsFor: 'code generation'!
emitExceptLast: stack on: aStream
    | nextToLast |
    nextToLast _ statements size - 1.
    nextToLast < 1 ifTrue: [^ self].  "Only one statement"
    1 to: nextToLast - 1 do:
        [:i | (statements at: i) emitForEffect: stack on: aStream].
    (returns  "Don't pop before a return"
            and: [(statements at: nextToLast) prefersValue])
        ifTrue: [(statements at: nextToLast) emitForValue: stack on: aStream]
        ifFalse: [(statements at: nextToLast) emitForEffect: stack on: aStream]! !

!BlockNode methodsFor: 'code generation'!
emitForEvaluatedEffect: stack on: aStream

    self returns
        ifTrue:
            [self emitForEvaluatedValue: stack on: aStream.
            stack pop: 1]
        ifFalse:
            [self emitExceptLast: stack on: aStream.
            statements last emitForEffect: stack on: aStream]! !

!BlockNode methodsFor: 'code generation'!
emitForEvaluatedValue: stack on: aStream
    self emitExceptLast: stack on: aStream.
    statements last emitForValue: stack on: aStream.
    (returns and: [statements size > 1
            and: [(statements at: statements size-1) prefersValue]])
        ifTrue: [stack pop: 1]  "compensate for elided pop prior to return"! !

!BlockNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

    aStream nextPut: LdThisContext.
    stack push: 1.
    nArgsNode emitForValue: stack on: aStream.
    remoteCopyNode
        emit: stack
        args: 1
        on: aStream.
    "Force a two byte jump."
    self emitLong: size code: JmpLong on: aStream.
    stack push: arguments size.
    arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream].
    self emitForEvaluatedValue: stack on: aStream.
    self returns ifFalse: [aStream nextPut: EndRemote].
    stack pop: 1! !

!BlockNode methodsFor: 'code generation'!
sizeExceptLast: encoder
    | codeSize nextToLast |
    nextToLast _ statements size - 1.
    nextToLast < 1 ifTrue: [^ 0]. "Only one statement"
    codeSize _ 0.
    1 to: nextToLast - 1 do:
        [:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)].
    ^ (returns  "Don't pop before a return"
            and: [(statements at: nextToLast) prefersValue])
        ifTrue: [codeSize + ((statements at: nextToLast) sizeForValue: encoder)]
        ifFalse: [codeSize + ((statements at: nextToLast) sizeForEffect: encoder)]! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedEffect: encoder

    self returns ifTrue: [^self sizeForEvaluatedValue: encoder].
    ^(self sizeExceptLast: encoder)
        + (statements last sizeForEffect: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForEvaluatedValue: encoder

    ^(self sizeExceptLast: encoder)
        + (statements last sizeForValue: encoder)! !

!BlockNode methodsFor: 'code generation'!
sizeForValue: encoder
    nArgsNode _ encoder encodeLiteral: arguments size.
    remoteCopyNode _ encoder encodeSelector: #blockCopy:.
    size _ (self sizeForEvaluatedValue: encoder)
                + (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
    arguments _ arguments collect:  "Chance to prepare debugger remote temps"
                [:arg | arg asStorableNode: encoder].
    arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
    ^1 + (nArgsNode sizeForValue: encoder)
        + (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! !


!BlockNode methodsFor: 'printing'!
printArgumentsOn: aStream indent: level

    arguments size = 0
        ifFalse:
            [arguments do:
                [:arg |
                aStream nextPut: $:.
                aStream nextPutAll: arg key.
                aStream space].
            aStream nextPutAll: '| '.
            "If >0 args and >1 statement, put all statements on separate lines"
            statements size > 1 ifTrue: [aStream crtab: level]]! !

!BlockNode methodsFor: 'printing'!
printOn: aStream indent: level

    statements size <= 1 ifFalse: [aStream crtab: level].
    aStream nextPut: $[.
    self printArgumentsOn: aStream indent: level.
    self printStatementsOn: aStream indent: level.
    aStream nextPut: $]! !

!BlockNode methodsFor: 'printing'!
printStatementsOn: aStream indent: levelOrZero
    | len shown thisStatement level |
    level _ 1 max: levelOrZero.
    comment == nil
        ifFalse:
            [self printCommentOn: aStream indent: level.
            aStream crtab: level].
    len _ shown _ statements size.
    (levelOrZero = 0 "top level" and: [statements last isReturnSelf])
        ifTrue: [shown _ 1 max: shown - 1]
        ifFalse: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)])
                    ifTrue: [shown _ shown - 1]].
    1 to: shown do:
        [:i |
        thisStatement _ statements at: i.
        thisStatement printOn: aStream indent: level.
        i < shown ifTrue: [aStream nextPut: $.; crtab: level].
        thisStatement comment size > 0
            ifTrue:
                [i = shown ifTrue: [aStream crtab: level].
                thisStatement printCommentOn: aStream indent: level.
                i < shown ifTrue: [aStream crtab: level]]]! !


!BlockNode methodsFor: 'equation translation'!
statements
    ^statements! !

!BlockNode methodsFor: 'equation translation'!
statements: val
    statements _ val! !


!BlockNode methodsFor: 'C translation'!
asTranslatorNode
    | statementList newS |
    statementList _ OrderedCollection new.
    statements do: [ :s |
        newS _ s asTranslatorNode.
        newS isStmtList ifTrue: [
            "inline the statement list returned when a CascadeNode is translated"
            statementList addAll: newS statements.
        ] ifFalse: [
            statementList add: newS.
        ].
    ].
    ^TStmtListNode new
        setArguments: (arguments asArray collect: [ :arg | arg key ])
        statements: statementList! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BlockNode class
    instanceVariableNames: ''!

!BlockNode class methodsFor: 'instance creation'!
withJust: aNode
    "Used to create a simple block, eg: withJust: NodeNil"
    ^ self new statements: (Array with: aNode) returns: false! !
AlignmentMorph subclass: #BookMorph
    instanceVariableNames: 'pageSize pages currentPage copyContents newPagePrototype '
    classVariableNames: 'PageFlipSoundOn '
    poolDictionaries: ''
    category: 'Morphic-Widgets'!

!BookMorph methodsFor: 'initialization' stamp: 'sw 5/6/1998 10:09'!
addDressing
    | controlColor pageControls |
    self addMorph: (Morph new color: color; extent: 10@10).  "spacer"
    controlColor _ (color saturation > 0.1)
        ifTrue:
            [color lighter]
        ifFalse:
            [color darker].
    pageControls _ Preferences noviceMode
        ifTrue:
            [self makeKidsPageControlsColored: controlColor]
        ifFalse:
            [self makeAuthoringPageControlsColored: controlColor].
    pageControls borderWidth: 1; inset: 4.

    self addMorph: pageControls! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 10/3/97 18:49'!
addKidsDressing
    | controlColor pageControls |
    self addMorph: (Morph new color: color; extent: 10@10).  "spacer"
    controlColor _ (color saturation > 0.1)
        ifTrue:
            [color lighter]
        ifFalse:
            [color darker].
    pageControls _ self makeKidsPageControlsColored: controlColor.
    pageControls borderWidth: 1; inset: 4.

    self addMorph: pageControls! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 10/18/97 18:03'!
beThoroughlyRepelling
    submorphs do: [:m | m beRepelling].
    self beRepelling! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/16/97 13:39'!
closeCurrentPageToDragNDrop
    currentPage ifNotNil: [currentPage openToDragNDrop: false]! !

!BookMorph methodsFor: 'initialization' stamp: 'jm 9/24/97 08:48'!
initialize

    super initialize.
    self setInitialState.
    pages _ OrderedCollection new.
    self addDressing.
    BookMorph turnOffSoundWhile: [self insertPage].
! !

!BookMorph methodsFor: 'initialization' stamp: 'jm 11/17/97 17:26'!
newPages: pageList currentIndex: index
    "Replace all my pages with the given list of BookPageMorphs. Make the current page be the page with the given index."

    pages _ pages species new.
    pages addAll: pageList.
    pages isEmpty ifTrue: [^ self insertPage].
    self goToPage: index.
! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/5/97 20:52'!
removeEverything
    currentPage _ nil.
    pages _ OrderedCollection new.
    super removeAllMorphs! !

!BookMorph methodsFor: 'initialization' stamp: 'sw 8/12/97 21:31'!
setInitialState
    orientation _ #vertical.
    centering _ #topLeft.
    hResizing _ #shrinkWrap.
    vResizing _ #shrinkWrap.
    inset _ 5.
    color _ Color white.
    pageSize _ 160@300.
    openToDragNDrop _ true.
    copyContents _ false.! !


!BookMorph methodsFor: 'accessing' stamp: 'tk 12/18/97 09:44'!
allNonSubmorphMorphs
    "Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"

    ^ pages copyWithout: currentPage! !

!BookMorph methodsFor: 'accessing' stamp: 'sw 11/5/97 13:37'!
currentPage
    ^ currentPage! !

!BookMorph methodsFor: 'accessing' stamp: 'sw 9/20/97 20:29'!
pageNamed: aName
    ^ pages detect: [:p | p externalName = aName] ifNone: [nil]! !

!BookMorph methodsFor: 'accessing'!
pages

    ^ pages
! !

!BookMorph methodsFor: 'accessing' stamp: 'tk 8/13/97 17:01'!
pages: aMorphList

    pages _ aMorphList asOrderedCollection.

    "John:  While it is tempting to put this code here, it is wrong.
    pages size > 0
        ifTrue: [currentPage _ pages first]
        ifFalse: [self insertPage].
    If currentPage is not page 1, then when it comes back in, two pages
are shown at once!!
    Just trust the copying mechanism and let currentPage be copied
correctly. --Ted."! !

!BookMorph methodsFor: 'accessing'!
pageSize: aPoint

    pageSize _ aPoint.
! !


!BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:03'!
acceptDroppingMorph: aMorph event: evt
    "Allow the user to add submorphs just by dropping them on this morph."

    (currentPage allMorphs includes: aMorph)
        ifFalse: [currentPage addMorph: aMorph]! !

!BookMorph methodsFor: 'dropping/grabbing'!
allowSubmorphExtraction

    ^ false! !

!BookMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/18/97 18:19'!
rootForGrabOf: aMorph

    | root |
    (openToDragNDrop or: [copyContents])
        ifFalse: [^ super rootForGrabOf: aMorph].
    (aMorph = currentPage or: [aMorph owner = self])
        ifTrue: [^ self rootForGrabOf: self].

    root _ aMorph.
    [root = self] whileFalse:
        [root owner == currentPage ifTrue:
            [(copyContents and: [openToDragNDrop not])
                ifTrue: [^ root fullCopy]
                ifFalse: [^ root]].
        root _ root owner].
    ^ super rootForGrabOf: aMorph
! !


!BookMorph methodsFor: 'zooming page turns'!
goToPage: pageNumber zoomingFrom: srcButtonMorph

    | bigBalloonMorph i newPage cachedMorph zoomer |
    pages isEmpty ifTrue: [^ self].

    (self isInWorld and:
     [self world modelOrNil respondsTo: #bigBalloonMorph])
        ifTrue: [bigBalloonMorph _ self world model bigBalloonMorph fullCopy]
        ifFalse: [^ self goToPage: pageNumber].

    bigBalloonMorph position: self world model scaffoldingBook root fullBounds origin.
    bigBalloonMorph removeAllMorphs.
    i _ pageNumber asInteger.
    i > pages size ifTrue: [i _ 1].  "wrap"
    i < 1  ifTrue: [i _ pages size].  "wrap"
    newPage _ pages at: i.
    cachedMorph _ CachingMorph new.
    cachedMorph addMorph: bigBalloonMorph.
    bigBalloonMorph addMorph: newPage fullCopy.
    zoomer _ ZoomMorph new.
    self world addMorphFront: zoomer.
    zoomer zoomFromMorph: srcButtonMorph
                            toMorph: cachedMorph
                            andThen: [self goToPage: i].
    self world ifNotNil: [self world startSteppingSubmorphsOf: zoomer].
! !

!BookMorph methodsFor: 'zooming page turns'!
nextPageZoomingFrom: aMorph

    | i |
    i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.
    self goToPage: i zoomingFrom: aMorph.
! !

!BookMorph methodsFor: 'zooming page turns'!
previousPageZoomingFrom: aMorph

    | i |
    i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.
    self goToPage: i zoomingFrom: aMorph.
! !

!BookMorph methodsFor: 'zooming page turns' stamp: 'di 1/21/98 07:06'!
showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending
    ascending ifNotNil:
        [self playPageFlipSound.
        (PageFlipSoundOn and: [oldOrigin ~~ nil]) ifTrue:
            [Display wipeImage: currentPage imageForm
                at: oldOrigin
                delta: (ascending ifTrue: [0@-4] ifFalse: [0@4])]]! !


!BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:45'!
addBookMenuItemsTo: aCustomMenu hand: aHandMorph
    aCustomMenu
        add: (copyContents
                ifTrue: ['don''t be parts bin when closed']
                ifFalse: ['be parts bin when closed'])
        action: #toggleCopyContents.
    aCustomMenu add: 'previous page' action: #previousPage.
    aCustomMenu add: 'next page' action: #nextPage.
    aCustomMenu add: 'insert a page' action: #insertPage.
    aCustomMenu add: 'delete this page' action: #deletePage.
    aCustomMenu add: 'page controls' action: #pageControls:.
    aCustomMenu add: 'sort pages' action: #sortPages:.
    aCustomMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
    newPagePrototype ifNotNil: [
        aCustomMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

    (aHandMorph classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue:
        [aCustomMenu add: 'paste book page'    action: #pasteBookPage]
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 9/13/97 23:24'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    self addBookMenuItemsTo: aCustomMenu hand: aHandMorph
    "This factoring allows subclasses, such as TabbedPaletteMorph, to choose different items and different wording and still use the super call for the rest of the metamenu"! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:18'!
clearNewPagePrototype
    "Clear the new page prototype."

    newPagePrototype _ nil.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 15:22'!
configureForKids
    super configureForKids.
    pages do:
        [:aPage | aPage configureForKids].! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/15/97 22:01'!
deleteControls
    "If the receiver has an element answering to the name 'Page Controls', delete it"

    | controls |
    (controls _ self findSubmorphThat: [:m | m externalName = 'Page Controls'] ifAbsent: [nil]) ifNotNil:
        [controls delete.
        self changed]! !

!BookMorph methodsFor: 'menu'!
deletePage

    | oldPage |
    oldPage _ currentPage.
    self nextPage.
    pages remove: oldPage.
    oldPage delete.
    currentPage = oldPage ifTrue: [self nextPage].
    pages isEmpty ifTrue: [self insertPage].
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/4/97 12:05'!
firstPage

    self goToPage: 1.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/9/97 00:02'!
insertPage
    self insertPageColored: self color
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/12/97 21:48'!
insertPage: aPage pageSize: aPageSize
    ^ self insertPage: aPage pageSize: aPageSize atIndex: (pages size + 1)! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:06'!
insertPage: aPage pageSize: aPageSize atIndex: anIndex

    | sz  predecessor |
    sz _ aPageSize
        ifNil: [currentPage == nil
            ifTrue: [pageSize]
            ifFalse: [currentPage extent]]
        ifNotNil:
            [aPageSize].
    aPage extent: sz.
    ((pages isEmpty | anIndex == nil) or: [anIndex > pages size])
        ifTrue:
            [pages add: aPage]
        ifFalse:
            [anIndex <= 1
                ifTrue:
                    [pages addFirst: aPage]
                ifFalse:
                    [predecessor _ anIndex == nil
                        ifTrue:
                            [currentPage]
                        ifFalse:
                            [pages at: anIndex].
                    self pages add: aPage after: predecessor]].

    self goToPageMorph: aPage
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:37'!
insertPageColored: aColor

    | sz newPage bw bc |
    currentPage == nil
        ifTrue:
            [sz _ pageSize.
            bw _ 0.
            bc _ Color blue muchLighter]
        ifFalse:
            [sz _ currentPage extent.
            bw _ currentPage borderWidth.
            bc _ currentPage borderColor].
    newPagePrototype
        ifNil: [
            newPage _ PasteUpMorph new extent: sz; color: aColor.
            newPage borderWidth: bw; borderColor: bc]
        ifNotNil: [
            newPage _ newPagePrototype fullCopy].
    newPage resizeToFit: false.
    pages isEmpty
        ifTrue: [pages add: (currentPage _ newPage)]
        ifFalse: [pages add: newPage after: currentPage].
    self nextPage.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:31'!
insertPageShowingString: aString fontName: aName fontSize: aSize
    "For creating text content on a page of a BookMorph, from cold code.  Sadly, can't yet specify font..."
    | aTextMorph tempContents |
    self insertPage.
    aTextMorph _ TextMorph new.
    aTextMorph extent: (self extent - (12@0)).
    aName ifNotNil:
            [aTextMorph string: aString fontName: aName size: aSize]
        ifNil:
            [aTextMorph contentsWrapped: aString].
    tempContents _ aTextMorph contents.
    aTextMorph contentsWrapped: '-'.
    aTextMorph extent: (self extent - (12@0)).
    aTextMorph contentsWrapped: tempContents.

    currentPage addMorph: aTextMorph.! !

!BookMorph methodsFor: 'menu' stamp: 'sw 9/15/97 01:05'!
insertPageShowingString: aString usingFont: aFont
    "For creating text content on a page of a BookMorph, from cold code.  Sadly, can't yet specify font..."

    self insertPage.
    currentPage addMorph:
        (TextMorph new extent: (self extent - (12@0)); contentsWrapped: aString)! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/15/1998 06:46'!
invokeBookMenu
    "Answer a menu to be popped up from the book-control panel"
    | aMenu |
    aMenu _ CustomMenu new.
    aMenu addList:    #(
        "    ('border color...'         changeBorderColor:)
            ('border width...'         changeBorderWidth:)
            ('lock'                    lock)"
            ('make bookmark'        bookmarkForThisPage)
            ('sort pages'                sortPages:)
            ('remove control panel'    deleteControls)
        ).
    (self primaryHand classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue:
        [aMenu add: 'paste book page'    action: #pasteBookPage].

    aMenu add: 'save as new-page prototype' action: #setNewPagePrototype.
    newPagePrototype ifNotNil: [
        aMenu add: 'clear new-page prototype' action: #clearNewPagePrototype].

    aMenu add: (openToDragNDrop ifTrue: ['close'] ifFalse: ['open']) , ' dragNdrop'
            action: #openCloseDragNDrop.

    aMenu invokeOn: self defaultSelection: nil! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/4/97 12:05'!
lastPage
    self goToPage: pages size
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/5/97 21:13'!
newTextMorph
    "Create a new, empty TextMorph that can be placed in this book."

    self isInWorld ifTrue:
        [self primaryHand attachMorph:
            (TextMorph new extent: currentPage width@30)].
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/1/97 00:18'!
nextPage

    | i |
    currentPage == nil ifTrue: [^ self goToPage: 1].
    i _ (pages indexOf: currentPage ifAbsent: [0]) + 1.
    self goToPage: i.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 10/2/97 21:39'!
pageControls: evt

    | buttonPanel |
    buttonPanel _ self makePageControls.
    buttonPanel borderWidth: 1; inset: 4.
    evt hand attachMorph: buttonPanel.
! !

!BookMorph methodsFor: 'menu' stamp: 'sw 5/14/1998 11:04'!
pasteBookPage
    | aPage |
    aPage _ self primaryHand objectToPaste.

    self insertPage: aPage pageSize: aPage extent atIndex: ((pages indexOf: currentPage) - 1).
    "self goToPageMorph: aPage"! !

!BookMorph methodsFor: 'menu' stamp: 'sw 8/11/97 23:40'!
previousPage

    | i |
    i _ (pages indexOf: currentPage ifAbsent: [2]) - 1.
    self goToPage: i.
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 5/14/1998 20:17'!
setNewPagePrototype
    "Record the current page as the prototype to be copied when inserting new pages."

    currentPage ifNotNil:
        [newPagePrototype _ currentPage fullCopy].
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 11/17/97 17:33'!
sortPages: evt

    | sorter |
    sorter _ BookPageSorterMorph new forBook: self.
    sorter pageHolder cursor: (pages indexOf: currentPage ifAbsent: [0]).
    evt == nil
        ifTrue: [self world addMorphFront: sorter]
        ifFalse: [evt hand attachMorph: sorter].
! !

!BookMorph methodsFor: 'menu' stamp: 'jm 7/8/97 10:44'!
toggleCopyContents
    "Toggle this morph's ability to behave like a parts bin when closed."

    copyContents _ copyContents not.
! !


!BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 11:46'!
authorControlSpecs
    ^ #(
            ( '<--'        firstPage        'Go to first page')
            ( '<-'         previousPage    'Go to previous page')
            ('-'            deletePage        'Delete current page')
            ('<<>>'        invokeBookMenu 'Get a menu')
            ('+'            insertPage        'Insert new page after this one')
            ('->'            nextPage        'Go to next page')
            ( '-->'        lastPage            'Go to final page'))! !

!BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:16'!
bookmarkForThisPage

    | b |
    b _ SimpleButtonMorph new target: self.
    b actionSelector: #goToPageMorph:.
    b label: 'Bookmark'.
    b arguments: (Array with: currentPage).
    self primaryHand attachMorph: b
! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/13/1998 15:11'!
goToPage: pageNumber

    | pageIndex  oldOrigin aWorld oldRect oldPageNumber ascending |
    pages isEmpty ifTrue: [^ self].

    oldPageNumber _ pages indexOf: currentPage ifAbsent: [1].

    pageIndex _ pageNumber asInteger.
    pageNumber < 1 ifTrue: [pageIndex _ pages size].
    pageNumber > pages size ifTrue: [pageIndex _ 1].


    ascending _ oldPageNumber < pageIndex.
    oldPageNumber = pageIndex ifTrue: [ascending _ nil].

    (aWorld _ self world) ifNotNil:
        [self primaryHand newKeyboardFocus: nil].
    currentPage ifNotNil:
        [(oldRect _ currentPage screenRectangle) ifNotNil:
            [oldOrigin _ oldRect origin].
        currentPage releaseCachedState; delete].
    currentPage _ pages at: pageIndex.
    self addMorphBack: currentPage.
    aWorld ifNotNil:
        [self world startSteppingSubmorphsOf: currentPage.
        self showPageTurningFeedbackFromOrigin: oldOrigin ascending: ascending]! !

!BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:43'!
goToPageMorph: aMorph

    | i |
    i _ pages indexOf: aMorph.
    i = 0 ifFalse: [self goToPage: i].
! !

!BookMorph methodsFor: 'private' stamp: 'sw 4/30/1998 12:16'!
goToPageMorphNamed: aName
    | aMorph |
    aMorph _ pages detect: [:p | p externalName = aName] ifNone: [^ self beep].
    self goToPageMorph: aMorph! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
insertPageLabel: labelString morphs: morphList

    | m c labelAllowance |
    self insertPage.
    labelString ifNotNil:
            [m _ (TextMorph new extent: currentPage width@20; contents: labelString).
        m lock.
        m position: currentPage position + (((currentPage width - m width) // 2) @ 5).
        currentPage addMorph: m.
        labelAllowance _ 40]
        ifNil:
            [labelAllowance _ 0].

    "use a column to align the given morphs, then add them to the page"
    c _ AlignmentMorph newColumn centering: #center.
    c addAllMorphs: morphList.
    c position: currentPage position + (0 @ labelAllowance).
    currentPage addAllMorphs: morphList.
    ^ currentPage
! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
insertPageLabel: labelString morphs: firstColMorphs secondColumnMorphs: secondColMorphs

    | c |
    self insertPageLabel: labelString morphs: firstColMorphs.

    "use a column to align the given morphs, then add them to the page"
    c _ AlignmentMorph newColumn centering: #center.
    c addAllMorphs: secondColMorphs.
    c position: currentPage position + (100@40).
    currentPage addAllMorphs: secondColMorphs.
! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'!
kidControlSpecs
    true ifTrue: [^ self minimalKidsControlSpecs].

    ^ #(
            ( '<--'        firstPage        'Go to first page')
            ( '<-'         previousPage    'Go to previous page')
            ('->'            nextPage        'Go to next page')
            ( '-->'        lastPage            'Go to final page'))! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:49'!
makeAuthoringPageControlsColored: aColor
    ^ self makePageControlsFrom: self authorControlSpecs color: aColor! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/2/97 18:50'!
makeKidsPageControlsColored: aColor
    ^ self makePageControlsFrom: self kidControlSpecs color: aColor! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/21/1998 18:08'!
makeMinimalControlsWithColor: aColor title: aString

    | aButton aColumn aRow but |
    aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0.
    aColumn _ AlignmentMorph newColumn.
    aColumn color: aButton color; borderWidth: 0; inset: 0.
    aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

    aRow _ AlignmentMorph newRow.
    aRow color: aButton color; borderWidth: 0; inset: 0.
    aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

    aRow addMorphBack: (but _ aButton fullCopy label: ' < ' ; actionSelector: #previousPage).
    but setBalloonText: 'Go to previous page'.

    aRow addMorphBack: (StringMorph contents: aString) lock.

    aRow addMorphBack: (but _ aButton fullCopy label: ' > ' ; actionSelector: #nextPage).
    but setBalloonText: 'Go to next page'.

    aColumn addMorphBack: aRow.

    aColumn setNameTo: 'Page Controls'.

    ^ aColumn! !

!BookMorph methodsFor: 'private' stamp: 'di 5/6/1998 21:10'!
makePageControls

    | b c r |
    b _ SimpleButtonMorph new target: self; borderColor: Color black.
    c _ AlignmentMorph newColumn.
    c color: b color; borderWidth: 0; inset: 0.
    c hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

    r _ AlignmentMorph newRow.
    r color: b color; borderWidth: 0; inset: 0.
    r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
    r addMorphBack: (b fullCopy label: '<-';            actionSelector: #previousPage).
    r addMorphBack: (b fullCopy label: 'Insert';        actionSelector: #insertPage).
    r addMorphBack: (b fullCopy label: 'Delete';        actionSelector: #deletePage).
    r addMorphBack: (b fullCopy label: 'Text';        actionSelector: #newTextMorph).
    r addMorphBack: (b fullCopy label: '->';            actionSelector: #nextPage).
    c addMorphBack: r.

    r _ r copy removeAllMorphs.
    r addMorphBack: (b fullCopy label: 'Bookmark';    actionSelector: #bookmarkForThisPage).
    r addMorphBack: (b fullCopy label: 'Save';        actionSelector: #saveBookToFile).
    c addMorphBack: r.

    ^ c
! !

!BookMorph methodsFor: 'private' stamp: 'sw 5/7/1998 09:06'!
makePageControlsFrom: controlSpecs color: aColor

    | aButton aColumn aRow but |
    aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor.
    aColumn _ AlignmentMorph newColumn.
    aColumn color: aButton color; borderWidth: 0; inset: 0.
    aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.

    aRow _ AlignmentMorph newRow.
    aRow color: aButton color; borderWidth: 0; inset: 0.
    aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
    controlSpecs do:
        [:pair | aRow addMorphBack: (but _ aButton fullCopy label: pair first; actionSelector: pair second).
        but setBalloonText: pair third.
        (pair last includesSubString: 'enu')
            ifTrue: [but actWhen: #buttonDown]].
    aColumn addMorphBack: aRow.

    aColumn setNameTo: 'Page Controls'.

    ^ aColumn! !

!BookMorph methodsFor: 'private' stamp: 'sw 10/18/97 18:03'!
minimalKidsControlSpecs
    ^ #(
            ( '<-'         previousPage    'Go to previous page')
            ('->'            nextPage        'Go to next page'))! !

!BookMorph methodsFor: 'private' stamp: 'jm 5/16/1998 10:39'!
playPageFlipSound

    (self world soundsEnabled "user-controllable" and:
        [PageFlipSoundOn])  "mechanism to suppress sounds at init time"
            ifTrue: [self playSoundNamed: 'camera'].
! !

!BookMorph methodsFor: 'private' stamp: 'jm 2/11/98 12:24'!
releaseCachedState
    "Release the cached state of all my pages."

    super releaseCachedState.
    pages do: [:page | page allMorphsDo: [:m | m releaseCachedState]].
! !

!BookMorph methodsFor: 'private' stamp: 'jm 7/1/97 16:55'!
saveBookToFile
    "Save this book in a file."

    | fileName s |
    fileName _ FillInTheBlank request: 'File name for this Book?'.
    fileName isEmpty ifTrue: [^ self].  "abort"

    s _ SmartRefStream newFileNamed: fileName, '.morph'.
    s nextPut: self fullCopy.
    s close.
! !

!BookMorph methodsFor: 'private' stamp: 'sw 8/12/97 12:30'!
switchToAuthorMode
    "Replace the control panel with one specially for authoring"

    self deleteControls.
    self addMorph: ((self makeAuthoringPageControlsColored: self color lighter) borderWidth: 1; inset: 4)

! !


!BookMorph methodsFor: 'copying' stamp: 'tk 8/13/97 15:00'!
copyRecordingIn: dict
    "Overridden to copy the pages of this book as well."

    | new |
    new _ super copyRecordingIn: dict.
    new pages: (pages collect: [:pg |
        "the current page was copied with the submorphs"
        (dict includesKey: pg)
            ifTrue: [dict at: pg]  "current page; already copied"
            ifFalse: [pg copyRecordingIn: dict]]).
    ^ new
! !

!BookMorph methodsFor: 'copying' stamp: 'jm 7/1/97 17:06'!
updateReferencesUsing: aDictionary

    super updateReferencesUsing: aDictionary.
    pages do: [:page |
        page allMorphsDo: [:m | m updateReferencesUsing: aDictionary]].
! !


!BookMorph methodsFor: 'object fileIn' stamp: 'di 5/21/1998 19:23'!
convertbosfcepbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm
    "These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ).
    This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."

    "Be sure to to fill in ('newPagePrototype' ) and deal with the information in ()"! !

!BookMorph methodsFor: 'object fileIn' stamp: 'jm 9/24/97 08:49'!
convertbosfcepbbochvimolppccs0: varDict bosfcepbbochvimolppcc0: smartRefStrm
    "These variables are automatically stored into the new instance ('pageSize' 'pages' 'currentPage' 'copyContents' ).
    This method is for additional changes. Use statements like (foo _ varDict at: 'foo')."

    "Be sure to to fill in () and deal with the information in ('saveBlock' )"! !

!BookMorph methodsFor: 'object fileIn' stamp: 'jm 5/15/1998 06:59'!
convertbosfcepcbbochvimolppcc0: varDict bosfcepcbbochvimolppccn0: smartRefStrm
    "Adding newPagePrototype instance variable."

    newPagePrototype _ nil.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BookMorph class
    instanceVariableNames: ''!

!BookMorph class methodsFor: 'all' stamp: 'sw 5/13/1998 11:43'!
authoringPrototype
    "Answer an instance of the receiver suitable for placing in a parts bin for authors"

    | book |
    book _ self new markAsPartsDonor.
    book removeEverything; pageSize: 128@102; color: (Color r: 0.9 g: 0.9 b: 0.9).
    book borderWidth: 1; borderColor: Color black.
    book addDressing; insertPage.
    ^ book! !

!BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:42'!
initialize
    "BookMorph initialize"

    PageFlipSoundOn _ true.
! !

!BookMorph class methodsFor: 'all' stamp: 'jm 9/24/97 08:47'!
turnOffSoundWhile: aBlock
    "Turn off page flip sound during the given block."

    | old |
    old _ PageFlipSoundOn.
    PageFlipSoundOn _ false.
    aBlock value.
    PageFlipSoundOn _ old.
! !
AlignmentMorph subclass: #BookPageSorterMorph
    instanceVariableNames: 'book pageHolder '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Widgets'!

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:42'!
acceptSort

    | pages |
    pages _ OrderedCollection new.
    pageHolder submorphsDo: [:m |
        (m isKindOf: BookPageThumbnailMorph) ifTrue: [pages add: m page]].
    book newPages: pages currentIndex: pageHolder cursor.
    self delete.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'di 5/6/1998 21:09'!
addControls

    | b r |
    b _ SimpleButtonMorph new target: self; borderColor: Color black.
    r _ AlignmentMorph newRow.
    r color: b color; borderWidth: 0; inset: 0.
    r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5.
    r centering: #topLeft.
    r addMorphBack: (b fullCopy label: 'Okay';    actionSelector: #acceptSort).
    r addMorphBack: (b fullCopy label: 'Cancel';    actionSelector: #cancelSort).
    self addMorphBack: r.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 15:14'!
cancelSort

    self delete.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:06'!
forBook: aBookMorph

    book _ aBookMorph.
    pageHolder removeAllMorphs.
    pageHolder addAllMorphs:
        (book pages collect: [:p | BookPageThumbnailMorph new page: p]).
    pageHolder extent: pageHolder width@pageHolder fullBounds height.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 19:40'!
initialize

    super initialize.
    self extent: 440@400;
        orientation: #vertical;
        centering: #topLeft;
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        inset: 3;
        color: Color lightGray;
        borderWidth: 2.
    pageHolder _ HolderMorph new extent: self extent - borderWidth.
    pageHolder cursor: 0.
    self addControls.
    self addMorphBack: pageHolder.
! !

!BookPageSorterMorph methodsFor: 'all' stamp: 'jm 11/17/97 16:46'!
pageHolder

    ^ pageHolder
! !
SketchMorph subclass: #BookPageThumbnailMorph
    instanceVariableNames: 'page '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Widgets'!

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:45'!
computeThumbnail

    | f scale |
    f _ page imageForm.
    scale _ self height / f height.  "keep height invariant"
    self form: (f magnify: f boundingBox by: scale@scale smoothing: 2).
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 14:01'!
initialize

    | f |
    super initialize.
    color _ Color lightGray.  "background color"
    f _ Form extent: 60@80 depth: 16.
    f fill: f boundingBox fillColor: color.
    self form: f.
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:30'!
page

    ^ page
! !

!BookPageThumbnailMorph methodsFor: 'all' stamp: 'jm 11/17/97 17:31'!
page: aBookPageMorph

    page _ aBookPageMorph.
    self computeThumbnail.
! !
Object subclass: #Boolean
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Objects'!
!Boolean commentStamp: 'di 5/22/1998 16:32' prior: 0!
Boolean comment:
'I represent logical values, providing boolean operations and conditional control structures.'!


!Boolean methodsFor: 'logical operations'!
& aBoolean
    "Evaluating conjunction. Evaluate the argument. Then answer true if
    both the receiver and the argument are true."

    self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
eqv: aBoolean
    "Answer true if the receiver is equivalent to aBoolean."

    ^self == aBoolean! !

!Boolean methodsFor: 'logical operations'!
not
    "Negation. Answer true if the receiver is false, answer false if the
    receiver is true."

    self subclassResponsibility! !

!Boolean methodsFor: 'logical operations'!
xor: aBoolean
    "Exclusive OR. Answer true if the receiver is not equivalent to aBoolean."

    ^(self == aBoolean) not! !

!Boolean methodsFor: 'logical operations'!
| aBoolean
    "Evaluating disjunction (OR). Evaluate the argument. Then answer true
    if either the receiver or the argument is true."

    self subclassResponsibility! !


!Boolean methodsFor: 'controlling'!
and: alternativeBlock
    "Nonevaluating conjunction. If the receiver is true, answer the value of
    the argument, alternativeBlock; otherwise answer false without
    evaluating the argument."

    self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: alternativeBlock
    "If the receiver is true (i.e., the condition is true), then the value is the
    true alternative, which is nil. Otherwise answer the result of evaluating
    the argument, alternativeBlock. Create an error notification if the
    receiver is nonBoolean. Execution does not actually reach here because
    the expression is compiled in-line."

    self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock
    "Same as ifTrue:ifFalse:."

    self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: alternativeBlock
    "If the receiver is false (i.e., the condition is false), then the value is the
    false alternative, which is nil. Otherwise answer the result of evaluating
    the argument, alternativeBlock. Create an error notification if the
    receiver is nonBoolean. Execution does not actually reach here because
    the expression is compiled in-line."

    self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
    "If the receiver is true (i.e., the condition is true), then answer the value
    of the argument trueAlternativeBlock. If the receiver is false, answer the
    result of evaluating the argument falseAlternativeBlock. If the receiver
    is a nonBoolean then create an error notification. Execution does not
    actually reach here because the expression is compiled in-line."

    self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
or: alternativeBlock
    "Nonevaluating disjunction. If the receiver is false, answer the value of
    the argument, alternativeBlock; otherwise answer true without
    evaluating the argument."

    self subclassResponsibility! !


!Boolean methodsFor: 'copying'!
deepCopy
    "Receiver has two concrete subclasses, True and False.
    Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'copying'!
shallowCopy
    "Receiver has two concrete subclasses, True and False.
    Only one instance of each should be made, so return self."! !


!Boolean methodsFor: 'printing' stamp: 'sw 4/25/1998 12:51'!
basicType
    ^ #boolean! !

!Boolean methodsFor: 'printing'!
storeOn: aStream
    "Refer to the comment in Object|storeOn:."

    self printOn: aStream! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Boolean class
    instanceVariableNames: ''!

!Boolean class methodsFor: 'instance creation'!
new
    self error: 'You may not create any more Booleans - this is two-valued logic'! !
ScriptEditorMorph subclass: #BooleanScriptEditor
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Support'!
!BooleanScriptEditor commentStamp: 'di 5/22/1998 16:32' prior: 0!
BooleanScriptEditor class comment:
'A ScriptEditor required to hold a Boolean'!


!BooleanScriptEditor methodsFor: 'all' stamp: 'sw 10/14/97 12:55'!
storeCodeOn: aStream
    (submorphs size > 0 and: [submorphs first submorphs size > 0]) ifTrue:
        [aStream nextPutAll: '(('.
        super storeCodeOn: aStream.
        aStream nextPutAll: ') ~~ false)'.
        ^ self].
    aStream nextPutAll: ' true '! !

!BooleanScriptEditor methodsFor: 'all' stamp: 'di 10/17/97 16:32'!
wantsDroppedMorph: aMorph

    ^ aMorph isTileLike and: [aMorph resultType ~~ #command]
! !
Morph subclass: #BorderedMorph
    instanceVariableNames: 'borderWidth borderColor '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Kernel'!

!BorderedMorph methodsFor: 'initialization' stamp: 'di 6/20/97 11:07'!
initialize
    super initialize.
    borderColor _ Color black.
    borderWidth _ 2.
! !


!BorderedMorph methodsFor: 'accessing' stamp: 'sw 8/6/97 14:34'!
borderColor
    ^ borderColor! !

!BorderedMorph methodsFor: 'accessing' stamp: 'jm 5/14/1998 11:07'!
borderColor: colorOrSymbolOrNil

    borderColor = colorOrSymbolOrNil ifFalse: [
        borderColor _ colorOrSymbolOrNil.
        self changed].
! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:24'!
borderInset
    self borderColor: #inset! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'!
borderRaised
    self borderColor: #raised! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:09'!
borderWidth
    ^ borderWidth! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/17/97 14:57'!
borderWidth: anInteger
    borderColor ifNil: [borderColor _ Color black].
    borderWidth _ anInteger max: 0.
    self changed! !

!BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:19'!
doesBevels
    "To return true means that this object can show bevelled borders, and
    therefore can accept, eg, #raised or #inset as valid borderColors.
    Must be overridden by subclasses that do not support bevelled borders."

    ^ true! !

!BorderedMorph methodsFor: 'accessing' stamp: 'sw 4/13/98 15:22'!
wearCostume: anotherMorph
    "Modify the receiver so that it resembles anotherMorph"

    super wearCostume: anotherMorph.
    self setBorderWidth: anotherMorph borderWidth borderColor: anotherMorph borderColor
! !


!BorderedMorph methodsFor: 'drawing' stamp: 'di 1/9/98 22:25'!
drawOn: aCanvas
    "Draw a rectangle with a solid, inset, or raised border.
    Note: the raised border color is generated from the receiver's own color,
    while the inset border color is generated from the color of its owner.
    This behavior is visually more consistent. Thanks to Hans-Martin Mosner."

    | insetColor |
    borderWidth = 0 ifTrue: [  "no border"
        aCanvas fillRectangle: bounds color: color.
        ^ self].

    borderColor == #raised ifTrue: [
        ^ aCanvas frameAndFillRectangle: bounds
            fillColor: color
            borderWidth: borderWidth
            topLeftColor: color lighter
            bottomRightColor: color darker].

    borderColor == #inset ifTrue: [
        insetColor _ owner colorForInsets.
        ^ aCanvas frameAndFillRectangle: bounds
            fillColor: color
            borderWidth: borderWidth
            topLeftColor: insetColor darker
            bottomRightColor: insetColor lighter].

    "solid color border"
    aCanvas frameAndFillRectangle: bounds
        fillColor: color
        borderWidth: borderWidth
        borderColor: borderColor.! !

!BorderedMorph methodsFor: 'drawing' stamp: 'di 5/17/1998 00:16'!
drawOnFills: aRectangle
    ^ (bounds containsRect: aRectangle) and: [self isOpaque]! !

!BorderedMorph methodsFor: 'drawing' stamp: 'di 5/22/1998 08:45'!
isOpaque
    color isTransparent ifTrue: [^ false].
    borderWidth = 0
        ifTrue: [^ true]
        ifFalse: [^ borderColor isColor not or: [borderColor isTransparent not]]! !


!BorderedMorph methodsFor: 'geometry' stamp: 'di 6/20/97 11:15'!
innerBounds
    ^ bounds insetBy: borderWidth! !


!BorderedMorph methodsFor: 'menu' stamp: 'sw 8/5/97 13:33'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    aCustomMenu addList: #(('border color...' changeBorderColor:)
                        ('border width...' changeBorderWidth:)).
    self doesBevels ifTrue:
        [borderColor == #raised ifFalse: [aCustomMenu add: 'raised bevel' action: #borderRaised].
        borderColor == #inset ifFalse: [aCustomMenu add: 'inset bevel' action: #borderInset]]
! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:08'!
changeBorderColor: evt
    | aHand |
    aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand].
    aHand changeColorTarget: self selector: #borderColor:.
! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/13/1998 12:11'!
changeBorderWidth: evt
    | handle origin aHand |
    aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand].
    origin _ aHand gridPointRaw.
    handle _ HandleMorph new forEachPointDo:
        [:newPoint | handle removeAllMorphs.
        handle addMorph:
            (PolygonMorph vertices: (Array with: origin with: newPoint)
                color: Color black borderWidth: 1 borderColor: Color black).
        self borderWidth: (newPoint - origin) r asInteger // 5].
    aHand attachMorph: handle.
    handle startStepping! !

!BorderedMorph methodsFor: 'menu' stamp: 'sw 5/21/1998 15:21'!
slotNamesAndTypesForBank: aNumber
    "Return an array of part names and part types for use in a viewer on the receiver's costumee; here we only put the costume-specific parts"
    ^ aNumber == 2
        ifTrue:
            [#(
            (color            color        readWrite    getColor                setColor:)
            (borderWidth         number        readWrite    getBorderWidth    setBorderWidth:)
            (borderColor            color        readWrite    getBorderColor    setBorderColor:)
        "(mouseX            number        readOnly    getMouseX            unused)"
        "(mouseY        number        readOnly    getMouseY            unused)"
)]

        ifFalse:
            [super slotNamesAndTypesForBank: aNumber]
! !


!BorderedMorph methodsFor: 'printing' stamp: 'di 6/20/97 11:20'!
fullPrintOn: aStream
    aStream nextPutAll: '('.
    super fullPrintOn: aStream.
    aStream nextPutAll: ') setBorderWidth: '; print: borderWidth;
        nextPutAll: ' borderColor: ' , (self colorString: borderColor)! !


!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:21'!
setBorderWidth: w borderColor: bc
    self borderWidth: w.
    self borderColor: bc.! !

!BorderedMorph methodsFor: 'private' stamp: 'di 6/20/97 11:22'!
setColor: c borderWidth: w borderColor: bc
    self color: c.
    self borderWidth: w.
    self borderColor: bc.! !
Morph subclass: #BouncingAtomsMorph
    instanceVariableNames: 'damageReported infectionHistory transmitInfection '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Demo'!
!BouncingAtomsMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
BouncingAtomsMorph comment:
'This morph shows how an ideal gas simulation might work. When it gets step messages, it makes all its atom submorphs move along their velocity vectors, bouncing when they hit a wall. It also exercises the Morphic damage reporting and display architecture. Here are some things to try:

  1. Resize this morph as the atoms bounce around.
  2. In an inspector on this morph, evaluate "self addAtoms: 10."
  3. Try setting quickRedraw to false in invalidRect:. This gives the
     default damage reporting and incremental redraw. Try it for
     100 atoms.
  4. In the drawOn: method of AtomMorph, change drawAsRect to true.
  5. Create a HeaterCoolerMorph and embed it in the simulation. Extract
    it and use an inspector on it to evaluate "self velocityDelta: -5", then
     re-embed it. Note the effect on atoms passing over it.
'!


!BouncingAtomsMorph methodsFor: 'all'!
addAtoms: n
    "Add a bunch of new atoms."

    | a |
    n timesRepeat: [
        a _ AtomMorph new.
        a randomPositionIn: bounds maxVelocity: 10.
        self addMorph: a].
    self stopStepping.! !

!BouncingAtomsMorph methodsFor: 'all'!
addMorphFront: aMorph
    "Called by the 'embed' meta action. We want non-atoms to go to the back."
    "Note: A user would not be expected to write this method. However, a sufficiently advanced user (e.g, an e-toy author) might do something equivalent by overridding the drag-n-drop messages when they are implemented."

    (aMorph isMemberOf: AtomMorph)
        ifTrue: [super addMorphFront: aMorph]
        ifFalse: [super addMorphBack: aMorph].! !

!BouncingAtomsMorph methodsFor: 'all'!
collisionPairs
    "Return a list of pairs of colliding atoms, which are assumed to be circles of known radius. This version uses the morph's positions--i.e. the top-left of their bounds rectangles--rather than their centers."

    | count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared |
    count _ submorphs size.
    sortedAtoms _ submorphs asSortedCollection:
        [ :m1 :m2 | m1 position x < m2 position x].
    radius _ 8.
    twoRadii _ 2 * radius.
    radiiSquared _ radius squared * 2.
    collisions _ OrderedCollection new.
    1 to: count - 1 do: [ :i |
        m1 _ sortedAtoms at: i.
        p1 _ m1 position.
        continue _ (j _ i + 1) <= count.
        [continue] whileTrue: [
            m2 _ sortedAtoms at: j.
            p2 _ m2 position.
            (p2 x - p1 x) <= twoRadii  ifTrue: [
                distSquared _ (p1 x - p2 x) squared + (p1 y - p2 y) squared.
                distSquared < radiiSquared ifTrue: [
                    collisions add: (Array with: m1 with: m2)].
                continue _ (j _ j + 1) <= count.
            ] ifFalse: [
                continue _ false.
            ].
        ].
    ].
    ^ collisions! !

!BouncingAtomsMorph methodsFor: 'all'!
drawOn: aCanvas
    "Clear the damageReported flag when redrawn."

    super drawOn: aCanvas.
    damageReported _ false.! !

!BouncingAtomsMorph methodsFor: 'all' stamp: 'jm 7/30/97 09:45'!
initialize

    super initialize.
    damageReported _ false.
    self extent: 400@250.
    self color: (Color r: 0.8 g: 1.0 b: 0.8).
    infectionHistory _ OrderedCollection new.
    transmitInfection _ false.
     self addAtoms: 30.
! !

!BouncingAtomsMorph methodsFor: 'all'!
invalidRect: damageRect
    "Try setting 'quickRedraw' to true. This invalidates the entire morph, whose bounds typically subsume all it's submorphs. (However, this code checks that assumption and passes through any damage reports for out-of-bounds submorphs. Note that atoms with super-high velocities do occaisionally shoot through the walls!!) An additional optimization is to only submit only damage report per display cycle by using the damageReported flag, which is reset to false when the morph is drawn."

    | quickRedraw |
    quickRedraw _ true.  "false gives the original invalidRect: behavior"
    (quickRedraw and:
     [(bounds origin <= damageRect topLeft) and:
     [damageRect bottomRight <= bounds corner]]) ifTrue: [
        "can use quick redraw if damage is within my bounds"
        damageReported ifFalse: [super invalidRect: bounds].  "just report once"
        damageReported _ true.
    ] ifFalse: [super invalidRect: damageRect].  "ordinary damage report"! !

!BouncingAtomsMorph methodsFor: 'all'!
setGermCount

    | countString count |
    countString _ FillInTheBlank
        request: 'Number of cells?'
        initialAnswer: self submorphCount printString.
    countString isEmpty ifTrue: [^ self].
    count _ Integer readFrom: (ReadStream on: countString).
    self removeAllMorphs.
    self addAtoms: count.
! !

!BouncingAtomsMorph methodsFor: 'all'!
startInfection

    self submorphsDo: [:m | m infected: false].
    self firstSubmorph infected: true.
    infectionHistory _ OrderedCollection new: 500.
    transmitInfection _ true.
    self startStepping.
! !

!BouncingAtomsMorph methodsFor: 'all'!
step
    "Bounce those atoms!!"

    | r |
    r _ bounds origin corner: (bounds corner - (8@8)).
    self submorphsDo: [ :m |
        (m isMemberOf: AtomMorph) ifTrue: [m bounceIn: r]].
    transmitInfection ifTrue: [self transmitInfection].
! !

!BouncingAtomsMorph methodsFor: 'all'!
stepTime
    "As fast as possible."

    ^ 0! !

!BouncingAtomsMorph methodsFor: 'all'!
transmitInfection

    | infected count graph |
    self collisionPairs do: [:pair |
        infected _ false.
        pair do: [:atom | atom infected ifTrue: [infected _ true]].
        infected
            ifTrue: [pair do: [:atom | atom infected: true]]].

    count _ 0.
    self submorphsDo: [:m | m infected ifTrue: [count _ count + 1]].
    infectionHistory addLast: count.
    count = submorphs size ifTrue: [
        "done!! place a graph of the infection history in the world"
        graph _ GraphMorph new data: infectionHistory.
        graph position: bounds topRight + (10@0).
        graph extent: (((infectionHistory size * 3) + (2 * graph borderWidth))@count).
        self world addMorph: graph.
        graph changed.
        transmitInfection _ false.
        self stopStepping].
! !
Object subclass: #BraceConstructor
    instanceVariableNames: 'elements initIndex subBraceSize constructor decompiler '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!

!BraceConstructor methodsFor: 'constructing'!
codeBrace: numElements fromBytes: aDecompiler withConstructor: aConstructor
    "Decompile.  Consume at least a Pop and usually several stores into variables
     or braces.  See BraceNode<formBrace for details."

    decompiler _ aDecompiler.
    constructor _ aConstructor.
    elements _ Array new: (initIndex _ numElements).
    [decompiler interpretNextInstructionFor: self.
     initIndex = 0]
        whileFalse: [].
    ^constructor codeBrace: elements! !


!BraceConstructor methodsFor: 'instruction decoding'!
doPop
    "Decompile."! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoLiteralVariable: association
    "Decompile."

    elements at: initIndex put: (constructor codeAnyLitInd: association).
    initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset
    "Decompile."

    elements at: initIndex put: (constructor codeInst: offset).
    initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset
    "Decompile."

    elements at: initIndex put: (decompiler tempAt: offset).
    initIndex _ initIndex - 1! !

!BraceConstructor methodsFor: 'instruction decoding'!
pushConstant: value

    subBraceSize _ value! !

!BraceConstructor methodsFor: 'instruction decoding'!
send: selector super: superFlag numArgs: numArgs

    selector == #toBraceStack:
        ifFalse: [self error: 'Malformed brace-variable code'].
    elements at: initIndex put:
        (BraceConstructor new
            codeBrace: subBraceSize
            fromBytes: decompiler
            withConstructor: constructor).
    initIndex _ initIndex - 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceConstructor class
    instanceVariableNames: ''!

!BraceConstructor class methodsFor: 'examples'!
example
    "Test the {a. b. c} syntax.  For more examples, see SequenceableCollection-casing
     and Dictionary-casing."

    | a b c d e x y |
    x _ {1. {2. 3}. 4}.
    {a. {b. c}. d. e} _ x, {5}, {}.
    y _ {a} _ {0}.
    {} _ {}.
    ^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !
ParseNode subclass: #BraceNode
    instanceVariableNames: 'elements sourceLocations collClassNode nElementsNode fromBraceStackNode toBraceStackNode withNode '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!

!BraceNode methodsFor: 'initialize-release'!
collClass: aParseNode

    collClassNode _ aParseNode! !

!BraceNode methodsFor: 'initialize-release'!
elements: collection
    "Decompile."

    elements _ collection! !

!BraceNode methodsFor: 'initialize-release'!
elements: collection sourceLocations: locations
    "Compile."

    elements _ collection.
    sourceLocations _ locations! !


!BraceNode methodsFor: 'testing'!
assignmentCheck: encoder at: location

    | loc |
    elements do:
        [:element |
        (loc _ element assignmentCheck: encoder at: location) >= 0 ifTrue: [^loc]].
    ^-1! !

!BraceNode methodsFor: 'testing'!
blockAssociationCheck: encoder
    "If all elements are MessageNodes of the form [block]->[block], and there is at
     least one element, answer true.
     Otherwise, notify encoder of an error."

    elements size = 0
        ifTrue: [^encoder notify: 'At least one case required'].
    elements with: sourceLocations do:
            [:x :loc |
            (x     isMessage: #->
                receiver:
                    [:rcvr |
                    (rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]]
                arguments:
                    [:arg |
                    (arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]])
              ifFalse:
                [^encoder notify: 'Association between 0-argument blocks required' at: loc]].
    ^true! !

!BraceNode methodsFor: 'testing'!
numElements

    ^ elements size! !


!BraceNode methodsFor: 'code generation'!
emitForValue: stack on: aStream
    "elem1, ..., elemN, collectionClass, N, fromBraceStack:"

    elements do: [:element | element emitForValue: stack on: aStream].
    collClassNode emitForValue: stack on: aStream.
    nElementsNode emitForValue: stack on: aStream.
    fromBraceStackNode emit: stack args: 1 on: aStream.
    stack pop: elements size! !

!BraceNode methodsFor: 'code generation'!
emitStore: stack on: aStream

    aStream nextPut: Dup. stack push: 1.
    self emitStorePop: stack on: aStream! !

!BraceNode methodsFor: 'code generation'!
emitStorePop: stack on: aStream
    "N, toBraceStack:, pop, pop elemN, ..., pop elem1"

    nElementsNode emitForValue: stack on: aStream.
    toBraceStackNode emit: stack args: 1 on: aStream.
    stack push: elements size.
    aStream nextPut: Pop. stack pop: 1.
    elements reverseDo: [:element | element emitStorePop: stack on: aStream]! !

!BraceNode methodsFor: 'code generation'!
sizeForStore: encoder

    ^1 + (self sizeForStorePop: encoder)! !

!BraceNode methodsFor: 'code generation'!
sizeForStorePop: encoder
    "N, toBraceStack:, pop, pop elemN, ..., pop elem1"

    nElementsNode _ encoder encodeLiteral: elements size.
    toBraceStackNode _ encoder encodeSelector: #toBraceStack:.
    ^elements inject:
        (nElementsNode sizeForValue: encoder) +
        (toBraceStackNode size: encoder args: 1 super: false) + 1 into:
            [:subTotal :element |
             subTotal + (element sizeForStorePop: encoder)]! !

!BraceNode methodsFor: 'code generation'!
sizeForValue: encoder
    "elem1, ..., elemN, collectionClass, N, fromBraceStack:"

    nElementsNode _ encoder encodeLiteral: elements size.
    collClassNode isNil ifTrue:
        [collClassNode _ encoder encodeVariable: #Array].
    fromBraceStackNode _ encoder encodeSelector: #fromBraceStack:.
    ^elements inject:
        (nElementsNode sizeForValue: encoder) +
        (collClassNode sizeForValue: encoder) +
        (fromBraceStackNode size: encoder args: 1 super: false)
     into:
        [:subTotal :element |
         subTotal + (element sizeForValue: encoder)]! !


!BraceNode methodsFor: 'enumerating'!
casesForwardDo: aBlock
    "For each case in forward order, evaluate aBlock with three arguments:
     the key block, the value block, and whether it is the last case."

    | numCases case |
    1 to: (numCases _ elements size) do:
        [:i |
        case _ elements at: i.
        aBlock value: case receiver value: case arguments first value: i=numCases]! !

!BraceNode methodsFor: 'enumerating'!
casesReverseDo: aBlock
    "For each case in reverse order, evaluate aBlock with three arguments:
     the key block, the value block, and whether it is the last case."

    | numCases case |
    (numCases _ elements size) to: 1 by: -1 do:
        [:i |
        case _ elements at: i.
        aBlock value: case receiver value: case arguments first value: i=numCases]! !

!BraceNode methodsFor: 'enumerating'!
do: aBlock
    "For each element in order, evaluate aBlock with two arguments: the element,
     and whether it is the last element."

    | numElements |
    1 to: (numElements _ elements size) do:
        [:i | aBlock value: (elements at: i) value: i=numElements]! !

!BraceNode methodsFor: 'enumerating'!
reverseDo: aBlock
    "For each element in reverse order, evaluate aBlock with two arguments: the element,
     and whether it is the last element."

    | numElements |
    (numElements _ elements size) to: 1 by: -1 do:
        [:i | aBlock value: (elements at: i) value: i=numElements]! !


!BraceNode methodsFor: 'printing'!
printOn: aStream indent: level

    | shown |
    aStream nextPut: ${.
    shown _ elements size.
    1 to: shown do:
        [:i |
        (elements at: i) printOn: aStream indent: level.
        i < shown ifTrue: [aStream nextPut: $.; space]].
    aStream nextPut: $}! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceNode class
    instanceVariableNames: ''!

!BraceNode class methodsFor: 'examples'!
example
    "Test the {a. b. c} syntax."

    | a b c d e x y |
    x _ {1. {2. 3}. 4}.
    {a. {b. c}. d. e} _ x, {5}, {}.
    y _ {a} _ {0}.
    {} _ {}.
    ^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !
StringHolder subclass: #Browser
    instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated '
    classVariableNames: 'RecentClasses '
    poolDictionaries: ''
    category: 'Interface-Browser'!
!Browser commentStamp: 'di 5/22/1998 16:32' prior: 0!
Browser comment:
'I represent a query path into the class descriptions, the software of the system.'!


!Browser methodsFor: 'initialize-release'!
browserWindowActivated
    "Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes.  The default is to do nothing.  8/5/96 sw"! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 15:22'!
buildClassSwitchView

    | aSwitchView |
    aSwitchView _ PluggableButtonView
        on: self
        getState: #classMessagesIndicated
        action: #indicateClassMessages.
    aSwitchView
        label: 'class';
        window: (0@0 extent: 15@8);
        askBeforeChanging: true.
    ^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'!
buildCommentSwitchView

    | aSwitchView |
    aSwitchView _ PluggableButtonView
        on: self
        getState: #classCommentIndicated
        action: #editComment.
    aSwitchView
        label: '?' asText allBold asParagraph;
        borderWidthLeft: 0 right: 1 top: 0 bottom: 0;
        window: (0@0 extent: 10@8);
        askBeforeChanging: true.
    ^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:11'!
buildInstanceClassSwitchView
    | aView aSwitchView instSwitchView comSwitchView |

    aView _ View new model: self.
    aView window: (0 @ 0 extent: 50 @ 8).
    instSwitchView _ self buildInstanceSwitchView.
    aView addSubView: instSwitchView.
    comSwitchView _ self buildCommentSwitchView.
    aView addSubView: comSwitchView toRightOf: instSwitchView.
    aSwitchView _ self buildClassSwitchView.
    aView addSubView: aSwitchView toRightOf: comSwitchView.
    ^aView! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 4/8/98 16:10'!
buildInstanceSwitchView

    | aSwitchView |
    aSwitchView _ PluggableButtonView
        on: self
        getState: #instanceMessagesIndicated
        action: #indicateInstanceMessages.
    aSwitchView
        label: 'instance';
        borderWidthLeft: 0 right: 1 top: 0 bottom: 0;
        window: (0@0 extent: 25@8);
        askBeforeChanging: true.
    ^ aSwitchView
! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 15:04'!
buildMorphicSwitches

    | instanceSwitch commentSwitch classSwitch row |
    instanceSwitch _ PluggableButtonMorph
        on: self
        getState: #instanceMessagesIndicated
        action: #indicateInstanceMessages.
    instanceSwitch
        label: 'instance';
        askBeforeChanging: true.
    commentSwitch _ PluggableButtonMorph
        on: self
        getState: #classCommentIndicated
        action: #editComment.
    commentSwitch
        label: '?' asText allBold asParagraph;
        askBeforeChanging: true.
    classSwitch _ PluggableButtonMorph
        on: self
        getState: #classMessagesIndicated
        action: #indicateClassMessages.
    classSwitch
        label: 'class';
        askBeforeChanging: true.
    row _ AlignmentMorph newRow
        hResizing: #spaceFill;
        vResizing: #spaceFill;
        inset: 0;
        borderColor: Color transparent;
        addMorphBack: instanceSwitch;
        addMorphBack: commentSwitch;
        addMorphBack: classSwitch.
    ^ row
! !

!Browser methodsFor: 'initialize-release'!
defaultBackgroundColor
    ^ #lightGreen! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:21'!
openAsMorphClassEditing: editString
    "Create a pluggable version a Browser on just a single class."
    | window codePane |
    window _ (SystemWindow labelled: 'later') model: self.

    window addMorph: (PluggableListMorph on: self list: #classListSingleton
            selected: #indexIsOne changeSelected: #indexIsOne:
            menu: #classListMenu:)
        frame: (0@0 extent: 0.5@0.06).
    window addMorph: self buildMorphicSwitches
        frame: (0.5@0 extent: 0.5@0.06).
    window addMorph: (PluggableListMorph on: self list: #messageCategoryList
            selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
            menu: #messageCategoryMenu:)
        frame: (0@0.06 extent: 0.5@0.30).
    window addMorph: (PluggableListMorph on: self list: #messageList
            selected: #messageListIndex changeSelected: #messageListIndex:
            menu: #messageListMenu:shifted:)
        frame: (0.5@0.06 extent: 0.5@0.30).

    codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    editString ifNotNil: [codePane editString: editString.
                    codePane hasUnacceptedEdits: true].
    window addMorph: codePane
        frame: (0@0.36 corner: 1@1).

    ^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 16:08'!
openAsMorphEditing: editString
    "Create a pluggable version of all the views for a Browser, including views and controllers."
    | window codePane |
    window _ (SystemWindow labelled: 'later') model: self.

    window addMorph: (PluggableListMorph on: self list: #systemCategoryList
            selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex:
            menu: #systemCategoryMenu:)
        frame: (0@0 extent: 0.25@0.4).
    window addMorph: (PluggableListMorph on: self list: #classList
            selected: #classListIndex changeSelected: #classListIndex:
            menu: #classListMenu:)
        frame: (0.25@0 extent: 0.25@0.3).
    window addMorph: self buildMorphicSwitches
        frame: (0.25@0.3 extent: 0.25@0.1).
    window addMorph: (PluggableListMorph on: self list: #messageCategoryList
            selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
            menu: #messageCategoryMenu:)
        frame: (0.5@0 extent: 0.25@0.4).
    window addMorph: (PluggableListMorph on: self list: #messageList
            selected: #messageListIndex changeSelected: #messageListIndex:
            menu: #messageListMenu:shifted:)
        frame: (0.75@0 extent: 0.25@0.4).

    codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    editString ifNotNil: [codePane editString: editString.
                    codePane hasUnacceptedEdits: true].
    window addMorph: codePane
        frame: (0@0.4 corner: 1@1).

    ^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'!
openAsMorphMessageEditing: editString
    "Create a pluggable version a Browser on just a messageCategory."
    | window codePane |
    window _ (SystemWindow labelled: 'later') model: self.

    window addMorph: (PluggableListMorph on: self list: #messageListSingleton
            selected: #indexIsOne changeSelected: #indexIsOne:
            menu: #messageListMenu:shifted:)
        frame: (0@0 extent: 1.0@0.06).

    codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    editString ifNotNil: [codePane editString: editString.
                    codePane hasUnacceptedEdits: true].
    window addMorph: codePane
        frame: (0@0.06 corner: 1@1).

    ^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/6/1998 21:36'!
openAsMorphMsgCatEditing: editString
    "Create a pluggable version a Browser on just a messageCategory."
    | window codePane |
    window _ (SystemWindow labelled: 'later') model: self.

    window addMorph: (PluggableListMorph on: self list: #messageCatListSingleton
            selected: #indexIsOne changeSelected: #indexIsOne:
            menu: #messageCategoryMenu:)
        frame: (0@0 extent: 1.0@0.06).
    window addMorph: (PluggableListMorph on: self list: #messageList
            selected: #messageListIndex changeSelected: #messageListIndex:
            menu: #messageListMenu:shifted:)
        frame: (0@0.06 extent: 1.0@0.30).

    codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    editString ifNotNil: [codePane editString: editString.
                    codePane hasUnacceptedEdits: true].
    window addMorph: codePane
        frame: (0@0.36 corner: 1@1).

    ^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:19'!
openAsMorphSysCatEditing: editString
    "Create a pluggable version of all the views for a Browser, including views and controllers."
    | window codePane |
    window _ (SystemWindow labelled: 'later') model: self.

    window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton
            selected: #indexIsOne changeSelected: #indexIsOne:
            menu: #systemCategoryMenu:)
        frame: (0@0 extent: 1.0@0.06).
    window addMorph: (PluggableListMorph on: self list: #classList
            selected: #classListIndex changeSelected: #classListIndex:
            menu: #classListMenu:)
        frame: (0@0.06 extent: 0.3333@0.24).
    window addMorph: self buildMorphicSwitches
        frame: (0@0.3 extent: 0.3333@0.06).
    window addMorph: (PluggableListMorph on: self list: #messageCategoryList
            selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex:
            menu: #messageCategoryMenu:)
        frame: (0.3333@0.06 extent: 0.3333@0.30).
    window addMorph: (PluggableListMorph on: self list: #messageList
            selected: #messageListIndex changeSelected: #messageListIndex:
            menu: #messageListMenu:shifted:)
        frame: (0.6666@0.06 extent: 0.3333@0.30).

    codePane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    editString ifNotNil: [codePane editString: editString.
                    codePane hasUnacceptedEdits: true].
    window addMorph: codePane
        frame: (0@0.36 corner: 1@1).

    ^ window! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/16/1998 17:07'!
openEditString: aString
    "Create a pluggable version of all the views for a Browser, including views and controllers."
    | systemCategoryListView classListView
    messageCategoryListView messageListView browserCodeView topView switchView |

    World ifNotNil: [^ self openAsMorphEditing: aString].
    Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString "testing"].

    topView _ (StandardSystemView new) model: self.
    topView borderWidth: 1.
        "label and minSize taken care of by caller"

    systemCategoryListView _ PluggableListView on: self
        list: #systemCategoryList
        selected: #systemCategoryListIndex
        changeSelected: #systemCategoryListIndex:
        menu: #systemCategoryMenu:.
    systemCategoryListView window: (0 @ 0 extent: 50 @ 70).
    topView addSubView: systemCategoryListView.

    classListView _ PluggableListView on: self
        list: #classList
        selected: #classListIndex
        changeSelected: #classListIndex:
        menu: #classListMenu:.
    classListView window: (0 @ 0 extent: 50 @ 62).
    topView addSubView: classListView toRightOf: systemCategoryListView.

    switchView _ self buildInstanceClassSwitchView.
    switchView borderWidth: 1.
    topView addSubView: switchView below: classListView.

    messageCategoryListView _ PluggableListView on: self
        list: #messageCategoryList
        selected: #messageCategoryListIndex
        changeSelected: #messageCategoryListIndex:
        menu: #messageCategoryMenu:.
    messageCategoryListView window: (0 @ 0 extent: 50 @ 70).
    topView addSubView: messageCategoryListView toRightOf: classListView.

    messageListView _ PluggableListView on: self
        list: #messageList
        selected: #messageListIndex
        changeSelected: #messageListIndex:
        menu: #messageListMenu:shifted:
        keystroke: #messageListKey:from:.
    messageListView window: (0 @ 0 extent: 50 @ 70).
    topView addSubView: messageListView toRightOf: messageCategoryListView.

    browserCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    browserCodeView window: (0@0 extent: 200@110).
    topView addSubView: browserCodeView below: systemCategoryListView.
    aString ifNotNil: [browserCodeView editString: aString.
            browserCodeView hasUnacceptedEdits: true].
    ^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'!
openMessageCatEditString: aString
    "Create a pluggable version of the views for a Browser that just shows one message category."
    | messageCategoryListView messageListView browserCodeView topView |

    World ifNotNil: [^ self openAsMorphMsgCatEditing: aString].

    topView _ (StandardSystemView new) model: self.
    topView borderWidth: 1.
        "label and minSize taken care of by caller"

    messageCategoryListView _ PluggableListView on: self
        list: #messageCatListSingleton
        selected: #indexIsOne
        changeSelected: #indexIsOne:
        menu: #messageCategoryMenu:.
    messageCategoryListView window: (0 @ 0 extent: 200 @ 12).
    topView addSubView: messageCategoryListView.

    messageListView _ PluggableListView on: self
        list: #messageList
        selected: #messageListIndex
        changeSelected: #messageListIndex:
        menu: #messageListMenu:shifted:
        keystroke: #messageListKey:from:.
    messageListView window: (0 @ 0 extent: 200 @ 70).
    topView addSubView: messageListView below: messageCategoryListView.

    browserCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    browserCodeView window: (0@0 extent: 200@(200-12-70)).
    topView addSubView: browserCodeView below: messageListView.
    aString ifNotNil: [browserCodeView editString: aString.
            browserCodeView hasUnacceptedEdits: true].
    ^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:27'!
openMessageEditString: aString
    "Create a pluggable version of the views for a Browser that just shows one message."
    | messageListView browserCodeView topView |

    World ifNotNil: [^ self openAsMorphMessageEditing: aString].

    topView _ (StandardSystemView new) model: self.
    topView borderWidth: 1.
        "label and minSize taken care of by caller"

    messageListView _ PluggableListView on: self
        list: #messageListSingleton
        selected: #indexIsOne
        changeSelected: #indexIsOne:
        menu: #messageListMenu:shifted:.
    messageListView window: (0 @ 0 extent: 200 @ 12).
    topView addSubView: messageListView.

    browserCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    browserCodeView window: (0@0 extent: 200@(200-12)).
    topView addSubView: browserCodeView below: messageListView.
    aString ifNotNil: [browserCodeView editString: aString.
            browserCodeView hasUnacceptedEdits: true].
    ^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/6/1998 21:25'!
openOnClassWithEditString: aString
    "Create a pluggable version of all the views for a Browser, including views and controllers."
    | classListView messageCategoryListView messageListView browserCodeView topView switchView |

    World ifNotNil: [^ self openAsMorphClassEditing: aString].

    topView _ (StandardSystemView new) model: self.
    topView borderWidth: 1.
        "label and minSize taken care of by caller"

    classListView _ PluggableListView on: self
        list: #classListSingleton
        selected: #indexIsOne
        changeSelected: #indexIsOne:
        menu: #classListMenu:.
    classListView window: (0 @ 0 extent: 100 @ 12).
    topView addSubView: classListView.

    messageCategoryListView _ PluggableListView on: self
        list: #messageCategoryList
        selected: #messageCategoryListIndex
        changeSelected: #messageCategoryListIndex:
        menu: #messageCategoryMenu:.
    messageCategoryListView window: (0 @ 0 extent: 100 @ 70).
    topView addSubView: messageCategoryListView below: classListView.

    messageListView _ PluggableListView on: self
        list: #messageList
        selected: #messageListIndex
        changeSelected: #messageListIndex:
        menu: #messageListMenu:shifted:
        keystroke: #messageListKey:from:.
    messageListView window: (0 @ 0 extent: 100 @ 70).
    topView addSubView: messageListView toRightOf: messageCategoryListView.

    switchView _ self buildInstanceClassSwitchView.
    switchView borderWidth: 1.
    switchView
        window: switchView window
        viewport: (classListView viewport topRight
                    corner: messageListView viewport topRight).
    topView addSubView: switchView toRightOf: classListView.

    browserCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    browserCodeView window: (0@0 extent: 200@(200-12-70)).
    topView addSubView: browserCodeView below: messageCategoryListView.
    aString ifNotNil: [browserCodeView editString: aString.
            browserCodeView hasUnacceptedEdits: true].
    ^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'di 5/8/1998 22:31'!
openSystemCatEditString: aString
    "Create a pluggable version of all the views for a Browser, including views and controllers.  The top list view is of the currently selected system class category--a single item list."
    | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView |

    World ifNotNil: [^ self openAsMorphSysCatEditing: aString].

    topView _ (StandardSystemView new) model: self.
    topView borderWidth: 1.
        "label and minSize taken care of by caller"

    systemCategoryListView _ PluggableListView on: self
        list: #systemCategorySingleton
        selected: #indexIsOne
        changeSelected: #indexIsOne:
        menu: #systemCategoryMenu:.
    systemCategoryListView window: (0 @ 0 extent: 200 @ 12).
    topView addSubView: systemCategoryListView.

    classListView _ PluggableListView on: self
        list: #classList
        selected: #classListIndex
        changeSelected: #classListIndex:
        menu: #classListMenu:.
    classListView window: (0 @ 0 extent: 67 @ 62).
    topView addSubView: classListView below: systemCategoryListView.

    messageCategoryListView _ PluggableListView on: self
        list: #messageCategoryList
        selected: #messageCategoryListIndex
        changeSelected: #messageCategoryListIndex:
        menu: #messageCategoryMenu:.
    messageCategoryListView window: (0 @ 0 extent: 66 @ 70).
    topView addSubView: messageCategoryListView toRightOf: classListView.

    switchView _ self buildInstanceClassSwitchView.
    switchView
        window: switchView window
        viewport: (classListView viewport bottomLeft
                    corner: messageCategoryListView viewport bottomLeft).
    switchView borderWidth: 1.
    topView addSubView: switchView below: classListView.

    messageListView _ PluggableListView on: self
        list: #messageList
        selected: #messageListIndex
        changeSelected: #messageListIndex:
        menu: #messageListMenu:shifted:
        keystroke: #messageListKey:from:.
    messageListView window: (0 @ 0 extent: 67 @ 70).
    topView addSubView: messageListView toRightOf: messageCategoryListView.

    browserCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    browserCodeView window: (0@0 extent: 200@(110-12)).
    topView addSubView: browserCodeView below: switchView.
    aString ifNotNil: [browserCodeView editString: aString.
            browserCodeView hasUnacceptedEdits: true].
    ^ topView
! !

!Browser methodsFor: 'initialize-release' stamp: 'tk 5/2/1998 14:35'!
setClass: aBehavior selector: aSymbol
    "Set the state of a new, uninitialized Browser."

    | isMeta aClass systemCatIndex messageCatIndex |
    aBehavior ifNil: [^ self].
    (aBehavior isKindOf: Metaclass)
        ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance]
        ifFalse: [isMeta _ false. aClass _ aBehavior].
    systemCatIndex _ SystemOrganization categories indexOf: aClass category.
    self systemCategoryListIndex: systemCatIndex.
    self classListIndex:
            ((SystemOrganization listAtCategoryNumber: systemCatIndex)
                    indexOf: aClass name).
    self metaClassIndicated: isMeta.
    aSymbol ifNil: [^ self].
    messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
    self messageCategoryListIndex: messageCatIndex.
    messageCatIndex = 0 ifTrue: [^ self].
    self messageListIndex:
            ((aBehavior organization listAtCategoryNumber: messageCatIndex)
                    indexOf: aSymbol).
! !

!Browser methodsFor: 'initialize-release'!
systemOrganizer: aSystemOrganizer
    "Initialize the receiver as a perspective on the system organizer,
    aSystemOrganizer. Typically there is only one--the system variable
    SystemOrganization."

    super initialize.
    contents _ nil.
    systemOrganizer _ aSystemOrganizer.
    systemCategoryListIndex _ 0.
    classListIndex _ 0.
    messageCategoryListIndex _ 0.
    messageListIndex _ 0.
    metaClassIndicated _ false.
    self setClassOrganizer.
    editSelection _ #none! !


!Browser methodsFor: 'accessing' stamp: 'tk 4/9/98 13:47'!
contents
    "Depending on the current selection, different information is retrieved.
    Answer a string description of that information. This information is the
    method of the currently selected class and message."
    | comment theClass |
    editSelection == #none ifTrue: [^ ''].
    editSelection == #editSystemCategories
        ifTrue: [^ systemOrganizer printString].
    editSelection == #newClass
        ifTrue: [^ Class template: self selectedSystemCategoryName].
    editSelection == #editClass
        ifTrue: [^ self selectedClassOrMetaClass definition].
    editSelection == #editComment
        ifTrue: [(theClass _ self selectedClass) ifNil: [^ ''].
                comment _ theClass comment.
                comment size = 0
                ifTrue: [ ^ 'This class has not yet been commented.']
                ifFalse: [ ^ comment]].
    editSelection == #hierarchy
        ifTrue: [^ self selectedClassOrMetaClass printHierarchy].
    editSelection == #editMessageCategories
        ifTrue: [^ self classOrMetaClassOrganizer printString].
    editSelection == #newMessage
        ifTrue: [^ self selectedClassOrMetaClass sourceCodeTemplate].
    editSelection == #editMessage
        ifTrue: [^ self selectedMessage].
    editSelection == #byteCodes ifTrue: [
        ^ (self selectedClassOrMetaClass compiledMethodAt:
                self selectedMessageName) symbolic asText].

    self error: 'Browser internal error: unknown edit selection.'! !

!Browser methodsFor: 'accessing' stamp: 'di 1/14/98 14:01'!
contents: input notifying: aController
    "The retrieved information has changed and its source must now be
    updated. The information can be a variety of things, depending on the
    list selections (such as templates for class or message definition, methods)
    or the user menu commands (such as definition, comment, hierarchy).
    Answer the result of updating the source."
    | aString aText theClass |
    aString _ input asString.
    aText _ input asText.

    editSelection == #editSystemCategories
        ifTrue: [^ self changeSystemCategories: aString].
    editSelection == #editClass | (editSelection == #newClass)
        ifTrue: [^ self defineClass: aString notifying: aController].
    editSelection == #editComment
        ifTrue: [theClass _ self selectedClass.
                theClass ifNil: [PopUpMenu notify: 'You must select a class
before giving it a comment.'.
                ^ false].
                theClass comment: aText. ^ true].
    editSelection == #hierarchy ifTrue: [^ true].
    editSelection == #editMessageCategories
        ifTrue: [^ self changeMessageCategories: aString].
    editSelection == #editMessage | (editSelection == #newMessage)
        ifTrue: [^ self defineMessage: aText notifying: aController].
    editSelection == #none
        ifTrue: [PopUpMenu notify: 'This text cannot be accepted
in this part of the browser.'.
                ^ false].
    self error: 'unacceptable accept'! !

!Browser methodsFor: 'accessing' stamp: 'tk 4/2/98 13:33'!
contentsSelection
    "Return the interval of text in the code pane to select when I set the pane's contents"

    messageCategoryListIndex > 0 & (messageListIndex = 0)
        ifTrue: [^ 1 to: 500]    "entire empty method template"
        ifFalse: [^ 1 to: 0]  "null selection"! !

!Browser methodsFor: 'accessing' stamp: 'di 5/6/1998 20:57'!
couldBrowseAnyClass
    "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name.  This implementation is clearly ugly, but the feature it enables is handsome enough.  3/1/96 sw"

    self dependents
        detect: [:d |
            (d class == PluggableListView) and:
            [d getListSelector == #systemCategoryList]]
        ifNone: [^ false].
    ^ true
! !

!Browser methodsFor: 'accessing'!
doItReceiver
    "This class's classPool has been jimmied to be the classPool of the class being browsed.  A doIt in the code pane will let the user see the value of the class variables."
    ^ FakeClassPool new! !

!Browser methodsFor: 'accessing'!
editSelection
    ^editSelection! !

!Browser methodsFor: 'accessing' stamp: 'jm 4/28/1998 05:55'!
request: prompt initialAnswer: initialAnswer

    ^ FillInTheBlank
        request: prompt
        initialAnswer: initialAnswer
! !

!Browser methodsFor: 'accessing' stamp: 'di 5/20/1998 22:48'!
spawn: aString
    "Create and schedule a new browser as though the command browse were
    issued with respect to one of the browser's lists. The initial textual
    contents is aString, which is the (modified) textual contents of the
    receiver."

    messageListIndex ~= 0
        ifTrue: [^self buildMessageBrowserEditString: aString].
    messageCategoryListIndex ~= 0
        ifTrue: [^self buildMessageCategoryBrowserEditString: aString].
    classListIndex ~= 0 ifTrue: [^self buildClassBrowserEditString: aString].
    systemCategoryListIndex ~= 0
        ifTrue: [^self buildSystemCategoryBrowserEditString: aString].
    ^Browser new openEditString: aString! !


!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne
    "When used as a singleton list, index is always one"
    ^ 1! !

!Browser methodsFor: 'system category list' stamp: 'tk 5/4/1998 15:46'!
indexIsOne: value
    "When used as a singleton list, can't change it"

    ^ self! !

!Browser methodsFor: 'system category list'!
selectedSystemCategoryName
    "Answer the name of the selected system category or nil."

    systemCategoryListIndex = 0 ifTrue: [^nil].
    ^self systemCategoryList at: systemCategoryListIndex! !

!Browser methodsFor: 'system category list'!
systemCategoryList
    "Answer the class categories modelled by the receiver."

    ^systemOrganizer categories! !

!Browser methodsFor: 'system category list'!
systemCategoryListIndex
    "Answer the index of the selected class category."

    ^systemCategoryListIndex! !

!Browser methodsFor: 'system category list' stamp: 'tk 4/2/98 13:41'!
systemCategoryListIndex: anInteger
    "Set the selected system category index to be anInteger. Update all other
    selections to be deselected."

    systemCategoryListIndex _ anInteger.
    classListIndex _ 0.
    messageCategoryListIndex _ 0.
    messageListIndex _ 0.
    editSelection _ anInteger = 0 ifTrue: [#none] ifFalse: [#newClass].
    metaClassIndicated _ false.
    self setClassOrganizer.
    contents _ nil.
    self changed: #systemCategorySelectionChanged.
    self changed: #systemCategoryListIndex.    "update my selection"
    self changed: #classList.
    self changed: #messageCategoryList.
    self changed: #messageList.
    self changed: #contents.
! !

!Browser methodsFor: 'system category list' stamp: 'tk 4/3/98 10:30'!
systemCategorySingleton

    | cat |
    cat _ self selectedSystemCategoryName.
    ^ cat ifNil: [Array new]
        ifNotNil: [Array with: cat]! !

!Browser methodsFor: 'system category list'!
toggleSystemCategoryListIndex: anInteger
    "If anInteger is the current system category index, deselect it. Else make
    it the current system category selection."

    self systemCategoryListIndex:
        (systemCategoryListIndex = anInteger
            ifTrue: [0]
            ifFalse: [anInteger])! !


!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:56'!
addSystemCategory
    "Prompt for a new category name and add it before the
    current selection, or at the end if no current selection"
    | oldIndex newName |
    self okToChange ifFalse: [^ self].
    oldIndex _ systemCategoryListIndex.
    newName _ self
        request: 'Please type new category name'
        initialAnswer: 'Category-Name'.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName _ newName asSymbol].
    systemOrganizer
        addCategory: newName
        before: (systemCategoryListIndex = 0
                ifTrue: [nil]
                ifFalse: [self selectedSystemCategoryName]).
    self systemCategoryListIndex:
        (oldIndex = 0
            ifTrue: [systemOrganizer categories size]
            ifFalse: [oldIndex]).
    self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/6/98 21:09'!
browseAllClasses
    "Create and schedule a new browser on all classes alphabetically."
    | newBrowser |
    newBrowser _ HierarchyBrowser new initAlphabeticListing.
    Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
        label: 'All Classes Alphabetically'! !

!Browser methodsFor: 'system category functions'!
buildSystemCategoryBrowser
    "Create and schedule a new system category browser."

    self buildSystemCategoryBrowserEditString: nil! !

!Browser methodsFor: 'system category functions' stamp: 'tk 5/4/1998 15:56'!
buildSystemCategoryBrowserEditString: aString
    "Create and schedule a new system category browser with initial textual
    contents set to aString."

    | newBrowser |
    systemCategoryListIndex > 0
        ifTrue:
            [newBrowser _ Browser new.
            newBrowser systemCategoryListIndex: systemCategoryListIndex.
            newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
            Browser openBrowserView: (newBrowser openSystemCatEditString: aString)
                label: 'Classes in category ', newBrowser selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:21'!
changeSystemCategories: aString
    "Update the class categories by parsing the argument aString."

    systemOrganizer changeFromString: aString.
    self changed: #systemCategoryList.
    ^ true! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:43'!
classNotFound

    self changed: #flash.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'!
editSystemCategories
    "Retrieve the description of the class categories of the system organizer."

    self okToChange ifFalse: [^ self].
    self systemCategoryListIndex: 0.
    editSelection _ #editSystemCategories.
    self changed: #editSystemCategories.
    self changed: #contents! !

!Browser methodsFor: 'system category functions' stamp: 'tk 3/31/98 07:52'!
fileOutSystemCategory
    "Print a description of each class in the selected category onto a file
    whose name is the category name followed by .st."

    systemCategoryListIndex ~= 0
        ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:44'!
findClass
    "Search for a class by name.  Modified so that if only 1 class matches the user-supplied string, or if the user-supplied string exactly matches a class name, then the pop-up menu is bypassed"
    | pattern foundClass classNames index reply |

    self okToChange ifFalse: [^ self classNotFound].
    pattern _ (reply _ FillInTheBlank request: 'Class Name?') asLowercase.
    pattern isEmpty ifTrue: [^ self classNotFound].
    (Smalltalk hasClassNamed: reply)
        ifTrue:
            [foundClass _ Smalltalk at: reply asSymbol]
        ifFalse:
             [classNames _ Smalltalk classNames asArray select:
                [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0].
            classNames isEmpty ifTrue: [^ self classNotFound].
            index _ classNames size == 1
                ifTrue:    [1]
                ifFalse:    [(PopUpMenu labelArray: classNames lines: #()) startUp].
            index = 0 ifTrue: [^ self classNotFound].
            foundClass _ Smalltalk at: (classNames at: index)].
     self systemCategoryListIndex: (self systemCategoryList indexOf: foundClass category).
    self classListIndex: (self classList indexOf: foundClass name).
! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:46'!
printOutSystemCategory
    "Print a description of each class in the selected category as Html."

Cursor write showWhile:
    [systemCategoryListIndex ~= 0
        ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName
                                asHtml: true ]]
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
removeSystemCategory
    "If a class category is selected, create a Confirmer so the user can
    verify that the currently selected class category and all of its classes
     should be removed from the system. If so, remove it."

    systemCategoryListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    (self classList size = 0
        or: [self confirm: 'Are you sure you want to
remove this system category
and all its classes?'])
        ifTrue:
        [systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
        self systemCategoryListIndex: 0.
        self changed: #systemCategoryList]! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:55'!
renameSystemCategory
    "Prompt for a new category name and add it before the
    current selection, or at the end if no current selection"
    | oldIndex oldName newName |
    (oldIndex _ systemCategoryListIndex) = 0
        ifTrue: [^ self].  "no selection"
    self okToChange ifFalse: [^ self].
    oldName _ self selectedSystemCategoryName.
    newName _ self
        request: 'Please type new category name'
        initialAnswer: oldName.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName _ newName asSymbol].
    oldName = newName ifTrue: [^ self].
    systemOrganizer
        renameCategory: oldName
        toBe: newName.
    self systemCategoryListIndex: oldIndex.
    self changed: #systemCategoryList.! !

!Browser methodsFor: 'system category functions' stamp: 'tk 4/2/98 13:48'!
systemCategoryMenu: aMenu

^ aMenu labels:
'find class...
recent classes...
browse all
browse
printOut
fileOut
reorganize
update
add item...
rename...
remove'
    lines: #(2 4 6 8)
    selections:
        #(findClass recent browseAllClasses buildSystemCategoryBrowser
        printOutSystemCategory fileOutSystemCategory
        editSystemCategories updateSystemCategories
        addSystemCategory renameSystemCategory removeSystemCategory )
! !

!Browser methodsFor: 'system category functions' stamp: 'di 4/12/98 13:17'!
updateSystemCategories
    "The class categories were changed in another browser. The receiver must
    reorganize its lists based on these changes."

    self okToChange ifFalse: [^ self].
    self changed: #systemCategoryList! !


!Browser methodsFor: 'class list'!
classList
    "Answer an array of the class names of the selected category. Answer an
    empty array if no selection exists."

    systemCategoryListIndex = 0
        ifTrue: [^Array new]
        ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]! !

!Browser methodsFor: 'class list'!
classListIndex
    "Answer the index of the current class selection."

    ^classListIndex! !

!Browser methodsFor: 'class list' stamp: 'tk 4/2/98 13:30'!
classListIndex: anInteger
    "Set anInteger to be the index of the current class selection."

    | className |
    classListIndex _ anInteger.
    self setClassOrganizer.
    messageCategoryListIndex _ 0.
    messageListIndex _ 0.
    self classCommentIndicated
        ifTrue: []
        ifFalse: [editSelection _ anInteger = 0
                    ifTrue: [metaClassIndicated
                        ifTrue: [#none]
                        ifFalse: [#newClass]]
                    ifFalse: [#editClass]].
    contents _ nil.
    self selectedClass isNil
        ifFalse: [className _ self selectedClass name.
                    (RecentClasses includes: className)
                ifTrue: [RecentClasses remove: className].
            RecentClasses addFirst: className.
            RecentClasses size > 16
                ifTrue: [RecentClasses removeLast]].
    self changed: #classSelectionChanged.
    self changed: #classListIndex.    "update my selection"
    self changed: #messageCategoryList.
    self changed: #messageList.
    self changed: #contents.
! !

!Browser methodsFor: 'class list' stamp: 'tk 4/5/98 12:25'!
classListSingleton

    | name |
    name _ self selectedClassName.
    ^ name ifNil: [Array new]
        ifNotNil: [Array with: name]! !

!Browser methodsFor: 'class list' stamp: 'sw 12/19/96'!
recent
    "Let the user select from a list of recently visited classes.  11/96 stp.
     12/96 di:  use class name, not classes themselves.
     : dont fall into debugger in empty case"

    | className class recentList |
    recentList _ RecentClasses select: [:n | Smalltalk includesKey: n].
    recentList size == 0 ifTrue: [^ self beep].
    className := (SelectionMenu selections: recentList) startUp.
    className == nil ifTrue: [^ self].
    class := Smalltalk at: className.
    self systemCategoryListIndex: (self systemCategoryList indexOf: class category).
    self classListIndex: (self classList indexOf: class name)! !

!Browser methodsFor: 'class list'!
selectClass: classNotMeta
    self classListIndex: (self classList findFirst: [:each | each == classNotMeta name])! !

!Browser methodsFor: 'class list' stamp: 'tk 4/4/98 18:48'!
selectedClass
    "Answer the class that is currently selected. Answer nil if no selection
    exists."

    | name |
    (name _ self selectedClassName) ifNil: [^ nil].
    ^ Smalltalk at: name! !

!Browser methodsFor: 'class list'!
selectedClassName
    "Answer the name of the current class. Answer nil if no selection exists."

    classListIndex = 0 ifTrue: [^nil].
    ^self classList at: classListIndex! !

!Browser methodsFor: 'class list'!
toggleClassListIndex: anInteger
    "If anInteger is the current class index, deselect it. Else make it the
    current class selection."

    self classListIndex:
        (classListIndex = anInteger
            ifTrue: [0]
            ifFalse: [anInteger])! !


!Browser methodsFor: 'class functions'!
buildClassBrowser
    "Create and schedule a new class category browser for the current class
    selection, if one exists."

    self buildClassBrowserEditString: nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:15'!
buildClassBrowserEditString: aString
    "Create and schedule a new class browser for the current selection, if one
    exists, with initial textual contents set to aString."

    | newBrowser |
    self selectedClass ifNotNil:
        [newBrowser _ Browser new.
        newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName.
        Browser openBrowserView: (newBrowser openOnClassWithEditString: aString)
            label: 'Class Browser: ', self selectedClassOrMetaClass name]
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/10/1998 12:44'!
classListMenu: aMenu

^ aMenu labels:
'browse class
browse full
printOut
fileOut
hierarchy
definition
comment
spawn hierarchy
spawn protocol
inst var refs..
inst var defs..
class var refs...
class vars
class refs
rename...
remove
unsent methods
find method...'
    lines: #(4 7 9 11 14 16)
    selections:
        #(buildClassBrowser browseMethodFull printOutClass fileOutClass
        hierarchy editClass editComment
        spawnHierarchy spawnProtocol
        browseInstVarRefs browseInstVarDefs browseClassVarRefs
        browseClassVariables browseClassRefs
        renameClass removeClass browseUnusedMethods findMethod)
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'!
defineClass: aString notifying: aController
    "The receiver's textual content is a request to define a new class. The
    source code is aString. If any errors occur in compilation, notify
    aController."

    | oldClass class |
    oldClass _ self selectedClassOrMetaClass.
    oldClass isNil ifTrue: [oldClass _ Object].
    class _ oldClass subclassDefinerClass
                evaluate: aString
                notifying: aController
                logged: true.
    (class isKindOf: Behavior)
        ifTrue:
            [self changed: #classList.
            self classListIndex:
                (self classList indexOf:
                    ((class isKindOf: Metaclass)
                        ifTrue: [class soleInstance name]
                        ifFalse: [class name])).
            self clearUserEditFlag; editClass.
            ^true]
        ifFalse: [^false]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'!
editClass
    "Retrieve the description of the class definition."

    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    self messageCategoryListIndex: 0.
    editSelection _ #editClass.
    self changed: #editClass.
    self changed: #contents.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:49'!
editComment
    "Retrieve the description of the class comment."

    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    self messageCategoryListIndex: 0.
    editSelection _ #editComment.
    self changed: #classSelectionChanged.
    self changed: #contents.
! !

!Browser methodsFor: 'class functions'!
explainSpecial: string
    "Answer a string explaining the code pane selection if it is displaying
    one of the special edit functions."

    | classes whole lits reply |
    (editSelection == #editClass or: [editSelection == #newClass])
        ifTrue:
            ["Selector parts in class definition"
            string last == $: ifFalse: [^nil].
            lits _ Array with:
                #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
            (whole _ lits detect: [:each | (each keywords
                    detect: [:frag | frag = string] ifNone: []) ~~ nil]
                        ifNone: []) ~~ nil
                ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.']
                ifFalse: [^nil].
            classes _ Smalltalk allClassesImplementing: whole.
            classes _ 'these classes ' , classes printString.
            ^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

    editSelection == #hierarchy
        ifTrue:
            ["Instance variables in subclasses"
            classes _ self selectedClassOrMetaClass allSubclasses.
            classes _ classes detect: [:each | (each instVarNames
                        detect: [:name | name = string] ifNone: []) ~~ nil]
                    ifNone: [^nil].
            classes _ classes printString.
            ^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
    editSelection == #editSystemCategories ifTrue: [^nil].
    editSelection == #editMessageCategories ifTrue: [^nil].
    ^nil! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
fileOutClass
    "Print a description of the selected class onto a file whose name is the
    category name followed by .st."

Cursor write showWhile:
        [classListIndex ~= 0 ifTrue: [self selectedClass fileOut]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
findMethod
    "Pop up a list of the current class's methods, and select the one chosen by the user.
    5/21/96 sw, based on a suggestion of John Maloney's."
    | aClass selectors reply cat messageCatIndex messageIndex |

    self classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    aClass _ self selectedClassOrMetaClass.
    selectors _ aClass selectors asSortedArray.
    reply _ (SelectionMenu labelList: selectors selections: selectors) startUp.
    reply == nil ifTrue: [^ self].
    cat _ aClass whichCategoryIncludesSelector: reply.
    messageCatIndex _ self messageCategoryList indexOf: cat.
    self messageCategoryListIndex: messageCatIndex.
    messageIndex _ (self messageList indexOf: reply).
    self messageListIndex: messageIndex.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
hierarchy
    "Display the inheritance hierarchy of the receiver's selected class."

    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    self messageCategoryListIndex: 0.
    editSelection := #hierarchy.
    self changed: #editComment.
    self changed: #contents.
    ^ self! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/2/98 13:50'!
printOutClass
    "Print a description of the selected class onto a file whose name is the
    category name followed by .html."

Cursor write showWhile:
        [classListIndex ~= 0 ifTrue: [self selectedClass fileOutAsHtml: true]]! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:52'!
removeClass
    "The selected class should be removed from the system. Use a Confirmer
    to make certain the user intends this irrevocable command to be carried
    out."
    | message class className |
    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    class _ self selectedClass.
    className _ class name.
    message _ 'Are you certain that you
want to delete the class ', className, '?'.
    (self confirm: message) ifTrue:
            [class subclasses size > 0
                ifTrue: [self notify: 'class has subclasses: ' , message].
            class removeFromSystem.
            self classListIndex: 0].
    self changed: #classList.
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/24/1998 23:54'!
renameClass
    | oldName newName obs |
    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    oldName _ self selectedClass name.
    newName _ (self request: 'Please type new class name'
                        initialAnswer: oldName) asSymbol.
    newName = oldName ifTrue: [^ self].
    (Smalltalk includesKey: newName)
        ifTrue: [^ self error: newName , ' already exists'].
    self selectedClass rename: newName.
    self changed: #classList.
    self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName).
    obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName).
    obs isEmpty ifFalse:
        [Smalltalk browseMessageList: obs
            name: 'Obsolete References to ' , oldName
            autoSelect: oldName].
! !

!Browser methodsFor: 'class functions' stamp: 'tk 4/7/98 13:25'!
spawnHierarchy
    "Create and schedule a new class hierarchy browser on the currently selected class or meta."
    | newBrowser aSymbol aBehavior messageCatIndex |
    classListIndex = 0 ifTrue: [^ self].
    newBrowser _ HierarchyBrowser new initHierarchyForClass: self selectedClass
            meta: self metaClassIndicated.
    (aSymbol _ self selectedMessageName) ifNotNil: [
        aBehavior _ self selectedClassOrMetaClass.
        messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
        newBrowser messageCategoryListIndex: messageCatIndex.
        newBrowser messageListIndex:
            ((aBehavior organization listAtCategoryNumber: messageCatIndex)
                        indexOf: aSymbol)].
    Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
        label: self selectedClassName , ' hierarchy'! !

!Browser methodsFor: 'class functions' stamp: 'di 7/13/97 16:43'!
spawnProtocol
        "Create and schedule a new protocol browser on the currently selected class or meta."
        classListIndex = 0 ifTrue: [^ self].
        ProtocolBrowser openSubProtocolForClass: self selectedClassOrMetaClass  ! !


!Browser methodsFor: 'message category list' stamp: 'tk 4/5/98 12:25'!
messageCatListSingleton

    | name |
    name _ self selectedMessageCategoryName.
    ^ name ifNil: [Array new]
        ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message category list'!
messageCategoryList
    "Answer the selected category of messages."

    classListIndex = 0
        ifTrue: [^Array new]
        ifFalse: [^self classOrMetaClassOrganizer categories]! !

!Browser methodsFor: 'message category list'!
messageCategoryListIndex
    "Answer the index of the selected message category."

    ^messageCategoryListIndex! !

!Browser methodsFor: 'message category list' stamp: 'tk 4/2/98 13:41'!
messageCategoryListIndex: anInteger
    "Set the selected message category to be the one indexed by anInteger."

    messageCategoryListIndex _ anInteger.
    messageListIndex _ 0.
    editSelection _
        anInteger = 0
            ifTrue: [#none]
            ifFalse: [#newMessage].
    contents _ nil.
    self changed: #messageCategorySelectionChanged.
    self changed: #messageCategoryListIndex.    "update my selection"
    self changed: #messageList.
    self changed: #contents.
! !

!Browser methodsFor: 'message category list'!
selectedMessageCategoryName
    "Answer the name of the selected message category, if any. Answer nil
    otherwise."

    messageCategoryListIndex = 0 ifTrue: [^nil].
    ^self messageCategoryList at: messageCategoryListIndex! !

!Browser methodsFor: 'message category list'!
toggleMessageCategoryListIndex: anInteger
    "If the currently selected message category index is anInteger, deselect
    the category. Otherwise select the category whose index is anInteger."

    self messageCategoryListIndex:
        (messageCategoryListIndex = anInteger
            ifTrue: [0]
            ifFalse: [anInteger])! !


!Browser methodsFor: 'message category functions' stamp: 'di 5/19/1998 23:58'!
addCategory
    "Prompt for a new category name and add it before the
    current selection, or at the end if no current selection"
    | oldIndex newName |
    self okToChange ifFalse: [^ self].
    classListIndex = 0 ifTrue: [^ self].
    oldIndex _ messageCategoryListIndex.
    newName _ self
        request: 'Please type new category name'
        initialAnswer: 'category name'.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName _ newName asSymbol].
    self classOrMetaClassOrganizer
        addCategory: newName
        before: (messageCategoryListIndex = 0
                ifTrue: [nil]
                ifFalse: [self selectedMessageCategoryName]).
    self changed: #messageCategoryList.
    self messageCategoryListIndex:
        (oldIndex = 0
            ifTrue: [self classOrMetaClassOrganizer categories size]
            ifFalse: [oldIndex]).
    self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions'!
buildMessageCategoryBrowser
    "Create and schedule a message category browser for the currently
    selected message category."

    self buildMessageCategoryBrowserEditString: nil! !

!Browser methodsFor: 'message category functions' stamp: 'tk 5/6/1998 21:30'!
buildMessageCategoryBrowserEditString: aString
    "Create and schedule a message category browser for the currently
    selected     message category. The initial text view contains the characters
    in aString."

    | newBrowser |
    messageCategoryListIndex ~= 0
        ifTrue:
            [newBrowser _ Browser new.
            newBrowser systemCategoryListIndex: systemCategoryListIndex.
            newBrowser classListIndex: classListIndex.
            newBrowser metaClassIndicated: metaClassIndicated.
            newBrowser messageCategoryListIndex: messageCategoryListIndex.
            newBrowser messageListIndex: messageListIndex.
            Browser openBrowserView: (newBrowser openMessageCatEditString: aString)
                label: 'Message Category Browser (' ,
                        newBrowser selectedClassOrMetaClassName , ')']! !

!Browser methodsFor: 'message category functions' stamp: 'jm 3/24/98 16:05'!
changeMessageCategories: aString
    "The characters in aString represent an edited version of the the message
    categories for the selected class. Update this information in the system
    and inform any dependents that the categories have been changed. This
    message is invoked because the user had issued the categories command
    and edited the message categories. Then the user issued the accept
    command."

    self classOrMetaClassOrganizer changeFromString: aString.
    Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
    self clearUserEditFlag.
    self editClass.
    self classListIndex: classListIndex.
    ^ true! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
editMessageCategories
    "Indicate to the receiver and its dependents that the message categories of
    the selected class have been changed."

    self okToChange ifFalse: [^ self].
    classListIndex ~= 0
        ifTrue:
            [self messageCategoryListIndex: 0.
            editSelection _ #editMessageCategories.
            self changed: #editMessageCategories.
            self changed: #contents]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
fileOutMessageCategories
    "Print a description of the selected message category of the selected class
    onto an external file."

Cursor write showWhile:
    [messageCategoryListIndex ~= 0
        ifTrue:
            [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
messageCategoryMenu: aMenu

^ aMenu labels:
'browse
printOut
fileOut
reorganize
add item...
rename...
remove'
    lines: #(3 4)
    selections:
        #(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories
        editMessageCategories
        addCategory renameCategory removeMessageCategory)
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:53'!
printOutMessageCategories
    "Print a description of the selected message category of the selected class
    onto an external file in Html format."

Cursor write showWhile:
    [messageCategoryListIndex ~= 0
        ifTrue:
            [self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName
                                        asHtml: true]]! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'!
removeMessageCategory
    "If a message category is selected, create a Confirmer so the user can
    verify that the currently selected message category should be removed
     from the system. If so, remove it."

    | messageCategoryName |
    messageCategoryListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    messageCategoryName _ self selectedMessageCategoryName.
    (self messageList size = 0
        or: [self confirm: 'Are you sure you want to
remove this method category
and all its methods?'])
        ifTrue:
            [self selectedClassOrMetaClass removeCategory: messageCategoryName.
            self messageCategoryListIndex: 0.
            self changed: #classSelectionChanged].
    self changed: #messageCategoryList.
! !

!Browser methodsFor: 'message category functions' stamp: 'tk 4/2/98 13:54'!
renameCategory
    "Prompt for a new category name and add it before the
    current selection, or at the end if no current selection"
    | oldIndex oldName newName |
    classListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self].
    oldName _ self selectedMessageCategoryName.
    newName _ self
        request: 'Please type new category name'
        initialAnswer: oldName.
    newName isEmpty
        ifTrue: [^ self]
        ifFalse: [newName _ newName asSymbol].
    newName = oldName ifTrue: [^ self].
    self classOrMetaClassOrganizer
        renameCategory: oldName
        toBe: newName.
    Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
    self classListIndex: classListIndex.
    self messageCategoryListIndex: oldIndex.
    self changed: #messageCategoryList.
! !


!Browser methodsFor: 'message list'!
messageList
    "Answer an Array of the message selectors of the currently selected
    message category. Otherwise, answer a new empty Array."

    messageCategoryListIndex = 0
        ifTrue: [^Array new]
        ifFalse: [^self classOrMetaClassOrganizer
                    listAtCategoryNumber: messageCategoryListIndex]! !

!Browser methodsFor: 'message list'!
messageListIndex
    "Answer the index of the selected message selector into the currently
    selected message category."

    ^messageListIndex! !

!Browser methodsFor: 'message list' stamp: 'tk 4/25/1998 00:11'!
messageListIndex: anInteger
    "Set the selected message selector to be the one indexed by anInteger."

    messageListIndex _ anInteger.
    editSelection _
        anInteger = 0
            ifTrue: [#newMessage]
            ifFalse: [#editMessage].
    contents _ nil.
    self changed: #messageListIndex.    "update my selection"
    self changed: #contents.
! !

!Browser methodsFor: 'message list' stamp: 'tk 4/6/98 10:48'!
messageListSingleton

    | name |
    name _ self selectedMessageName.
    ^ name ifNil: [Array new]
        ifNotNil: [Array with: name]! !

!Browser methodsFor: 'message list' stamp: 'tk 4/4/98 21:25'!
selectedMessage
    "Answer a copy of the source code for the selected message selector."
    | class selector method tempNames |
    contents == nil ifFalse: [^ contents copy].
    class _ self selectedClassOrMetaClass.
    selector _ self selectedMessageName.
    method _ class compiledMethodAt: selector.

    (Sensor controlKeyPressed
        or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) == nil]])
        ifTrue:
        ["Emergency or no source file -- decompile without temp names"
        contents _ (class decompilerClass new decompile: selector in: class method: method)
            decompileString.
        ^ contents copy].

    Sensor leftShiftDown ifTrue:
        ["Special request to decompile -- get temps from source file"
        tempNames _ (class compilerClass new
                        parse: method getSourceFromFile asString in: class notifying: nil)
                        tempNames.
        contents _ ((class decompilerClass new withTempNames: tempNames)
                decompile: selector
                in: class
                method: method) decompileString.
        contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass.
        ^ contents copy].

    contents _ class sourceCodeAt: selector.
    contents _ contents asText makeSelectorBoldIn: self selectedClassOrMetaClass.
    ^ contents copy! !

!Browser methodsFor: 'message list'!
selectedMessageName
    "Answer the message selector of the currently selected message, if any.
    Answer nil otherwise."

    messageListIndex = 0 ifTrue: [^nil].
    ^self messageList at: messageListIndex! !

!Browser methodsFor: 'message list'!
toggleMessageListIndex: anInteger
    "If the currently selected message index is anInteger, deselect the message
    selector. Otherwise select the message selector whose index is anInteger."

    self messageListIndex:
        (messageListIndex = anInteger
            ifTrue: [0]
            ifFalse: [anInteger])! !


!Browser methodsFor: 'message functions'!
browseImplementors
    "Create and schedule a message set browser on all implementors of the
    currently selected message selector. Do nothing if no message is selected."

    messageListIndex ~= 0
        ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]! !

!Browser methodsFor: 'message functions'!
buildMessageBrowser
    "Create and schedule a message browser on the currently selected
    message. Do nothing if no message is selected. The initial text view
    contains nothing."

    self buildMessageBrowserEditString: nil! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/6/98 21:47'!
buildMessageBrowserEditString: aString
    "Create and schedule a message browser for the receiver in which the
    argument, aString, contains characters to be edited in the text view."

    messageListIndex = 0 ifTrue: [^ self].
    ^ Browser openMessageBrowserForClass: self selectedClassOrMetaClass
        selector: self selectedMessageName editString: aString! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:08'!
defineMessage: aString notifying: aController
    "Compile the expressions in aString. Notify aController if a syntax error
    occurs. Install the compiled method in the selected class classified under
    the currently selected message category name. Answer true if
    compilation succeeds, false otherwise."
    | selectedMessageName selector category oldMessageList |
    selectedMessageName _ self selectedMessageName.
    oldMessageList _ self messageList.
    contents _ nil.
    selector _ self selectedClassOrMetaClass
                compile: aString
                classified: (category _ self selectedMessageCategoryName)
                notifying: aController.
    selector == nil ifTrue: [^ false].
    contents _ aString copy.
    selector ~~ selectedMessageName
        ifTrue:
            [category = ClassOrganizer nullCategory
                ifTrue: [self changed: #classSelectionChanged.
                        self changed: #classList.
                        self messageCategoryListIndex: 1].
            self setClassOrganizer.  "In case organization not cached"
            (oldMessageList includes: selector)
                ifFalse: [self changed: #messageList].
            self messageListIndex: (self messageList indexOf: selector)].
    ^ true! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectInstances
    "Inspect all instances of the selected class.  1/26/96 sw"

    | myClass |
    myClass _ self selectedClassOrMetaClass.
    myClass ~~ nil ifTrue:
        [myClass theNonMetaClass inspectAllInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:02'!
inspectSubInstances
    "Inspect all instances of the selected class and all its subclasses  1/26/96 sw"

    | aClass |
    aClass _ self selectedClassOrMetaClass.
    aClass ~~ nil ifTrue:
        [aClass _ aClass theNonMetaClass.
         aClass inspectSubInstances].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/18/1998 16:14'!
messageListMenu: aMenu shifted: shifted
    ^ shifted ifFalse: [aMenu labels:
'browse full
fileOut
printOut
senders of...
implementors of...
method inheritance
versions
inst var refs...
inst var defs...
class var refs...
class variables
class refs
remove
more...'
    lines: #(3 7 12)
    selections:
        #(browseMethodFull fileOutMessage printOutMessage
        browseSendersOfMessages browseMessages methodHierarchy browseVersions
        browseInstVarRefs browseInstVarDefs browseClassVarRefs
            browseClassVariables browseClassRefs
        removeMessage shiftedYellowButtonActivity )]

    ifTrue: [aMenu labels: 'browse class hierarchy
browse class
browse method
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
remove from this browser
revert to previous version
remove from current change set
revert and forget
more...'
    lines: #(5 7 11)
    selections: #(classHierarchy browseClass
        buildMessageBrowser browseAllMessages findMethodInChangeSets
        inspectInstances inspectSubInstances
        removeMessageFromBrowser revertToPreviousVersion
        removeFromCurrentChanges revertAndForget
        unshiftedYellowButtonActivity)]
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeFromCurrentChanges
    "Tell the changes mgr to forget that the current msg was changed."

    Smalltalk changes removeSelectorChanges: self selectedMessageName
            class: self selectedClassOrMetaClass.
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/25/1998 00:07'!
removeMessage
    "If a message is selected, create a Confirmer so the user can verify that
    the currently selected message should be removed from the system. If so,
    remove it.  If the Preference 'confirmMethodRemoves' is set to false, the
    confirmer is bypassed."
    | messageName confirmation |

    messageListIndex = 0 ifTrue: [^ self].
    self okToChange ifFalse: [^ self].
    messageName _ self selectedMessageName.
    confirmation _ self selectedClassOrMetaClass confirmRemovalOf: messageName.
    confirmation == 3 ifTrue: [^ self].

    self selectedClassOrMetaClass removeSelector: self selectedMessageName.
    self changed: #messageList.
    self messageListIndex: 0.
    self setClassOrganizer.  "In case organization not cached"

    confirmation == 2 ifTrue:
        [Smalltalk browseAllCallsOn: messageName]
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:03'!
removeMessageFromBrowser
    "Our list speaks the truth and can't have arbitrary things removed"

    ^ self changed: #flash! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/24/1998 23:46'!
revertAndForget
    "Revert to the previous version of the current method, and tell the changes mgr to forget that it was ever changed.  Danger!!  Use only if you really know what you're doing!!"

    self revertToPreviousVersion.
    self removeFromCurrentChanges.
    self changed: #contents! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 17:04'!
revertToPreviousVersion
    "Revert to the previous version of the current method"

    | aClass aSelector  changeRecords codeController |
    aClass _ self selectedClassOrMetaClass.
    aClass ifNil: [^ self changed: #flash].
    aSelector _ self selectedMessageName.
    changeRecords _ aClass changeRecordsAt: aSelector.
    changeRecords size <= 1 ifTrue: [self changed: #flash.  ^ self beep].
    codeController _ (self dependents detect: [:v | v isKindOf: PluggableTextView]) controller.
        "later find a better way to do this!!"
    self contents: (changeRecords at: 2) string notifying: codeController.
    self changed: #contents! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:57'!
shiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self messageListMenu: (CustomMenu new) shifted: true.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !

!Browser methodsFor: 'message functions' stamp: 'tk 4/2/98 20:58'!
unshiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self messageListMenu: (CustomMenu new) shifted: false.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !


!Browser methodsFor: 'code pane' stamp: 'tk 4/9/98 14:03'!
showBytecodes
    "Show the bytecodes of the selected method."
    "Set a mode for contents!!"

    ((self messageListIndex = 0) | (self okToChange not))
        ifTrue: [^ self changed: #flash].
    editSelection _ #byteCodes.
    self changed: #contents.
! !


!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 12:25'!
classCommentIndicated
    "Answer true iff we're viewing the class comment."

    ^ editSelection == #editComment
! !

!Browser methodsFor: 'metaclass'!
classMessagesIndicated
    "Answer whether the messages to be presented should come from the
    metaclass."

    ^ self metaClassIndicated! !

!Browser methodsFor: 'metaclass'!
classOrMetaClassOrganizer
    "Answer the class organizer for the metaclass or class, depending on
    which (instance or class) is indicated."

    self metaClassIndicated
        ifTrue: [^metaClassOrganizer]
        ifFalse: [^classOrganizer]! !

!Browser methodsFor: 'metaclass'!
indicateClassMessages
    "Indicate that the message selection should come from the metaclass
    messages."

    self metaClassIndicated: true! !

!Browser methodsFor: 'metaclass'!
indicateInstanceMessages
    "Indicate that the message selection should come from the class (instance)
    messages."

    self metaClassIndicated: false! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:20'!
instanceMessagesIndicated
    "Answer whether the messages to be presented should come from the
    class."

    ^metaClassIndicated not and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:19'!
metaClassIndicated
    "Answer the boolean flag that indicates which of the method dictionaries,
    class or metaclass."

    ^ metaClassIndicated and: [self classCommentIndicated not]! !

!Browser methodsFor: 'metaclass' stamp: 'tk 4/2/98 17:05'!
metaClassIndicated: trueOrFalse
    "Indicate whether browsing instance or class messages."
    metaClassIndicated _ trueOrFalse.
    self setClassOrganizer.
    systemCategoryListIndex > 0 ifTrue:
        [editSelection _ classListIndex = 0
            ifTrue: [metaClassIndicated
                ifTrue: [#none]
                ifFalse: [#newClass]]
            ifFalse: [#editClass]].
    messageCategoryListIndex _ 0.
    messageListIndex _ 0.
    contents _ nil.
    self changed: #classSelectionChanged.
    self changed: #messageCategoryList.
    self changed: #messageList.
    self changed: #contents.
! !

!Browser methodsFor: 'metaclass' stamp: 'tk 4/9/98 10:48'!
selectedClassOrMetaClass
    "Answer the selected class or metaclass."

    | cls |
    self metaClassIndicated
        ifTrue: [^ (cls _ self selectedClass) ifNil: [nil] ifNotNil: [cls class]]
        ifFalse: [^ self selectedClass]! !

!Browser methodsFor: 'metaclass'!
selectedClassOrMetaClassName
    "Answer the selected class name or metaclass name."

    ^self selectedClassOrMetaClass name! !

!Browser methodsFor: 'metaclass' stamp: 'di 1/14/98 13:27'!
setClassOrganizer
    "Install whatever organization is appropriate"
    | theClass |
    classOrganizer _ nil.
    metaClassOrganizer _ nil.
    classListIndex = 0 ifTrue: [^ self].
    classOrganizer _ (theClass _ self selectedClass) organization.
    metaClassOrganizer _ theClass class organization.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Browser class
    instanceVariableNames: ''!

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 17:37'!
fullOnClass: aClass
    "Open a new full browser set to class."
    | brow |
    brow _ Browser new.
    brow setClass: aClass selector: nil.
    Browser openBrowserView: (brow openEditString: nil)
        label: 'System Browser'! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 15:27'!
fullOnClass: aClass selector: aSelector
    "Open a new full browser set to class."

    | brow |
    brow _ Browser new.
    brow setClass: aClass selector: aSelector.
    Browser openBrowserView: (brow openEditString: nil)
        label: 'System Browser'! !

!Browser class methodsFor: 'instance creation'!
new

    ^super new systemOrganizer: SystemOrganization! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:04'!
newOnCategory: aCategory
    "Browse the system category of the given name.  7/13/96 sw"

    "Browser newOnCategory: 'Interface-Browser'"

    | newBrowser catList |
    newBrowser _ Browser new.
    catList _ newBrowser systemCategoryList.
    newBrowser systemCategoryListIndex:
        (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
    Browser openBrowserView: (newBrowser openSystemCatEditString: nil)
                label: 'Classes in category ', aCategory
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:28'!
newOnClass: aClass
    "Open a new class browser on this class."
    ^ self newOnClass: aClass label: 'Class Browser: ', aClass name! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 22:55'!
newOnClass: aClass label: aLabel
    "Open a new class browser on this class."
    | newBrowser |

    newBrowser _ Browser new.
    newBrowser setClass: aClass selector: nil.
    Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
            label: aLabel
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/18/1998 16:29'!
newOnClass: aClass selector: aSymbol
    "Open a new class browser on this class."
    | newBrowser |

    newBrowser _ Browser new.
    newBrowser setClass: aClass selector: aSymbol.
    Browser openBrowserView: (newBrowser openOnClassWithEditString: nil)
            label: 'Class Browser: ', aClass name
! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:28'!
openBrowser
    "Create and schedule a BrowserView with label 'System Browser'. The
    view consists of five subviews, starting with the list view of system
    categories of SystemOrganization. The initial text view part is empty."

    Browser openBrowserView: (Browser new openEditString: nil)
            label: 'System Browser'
! !

!Browser class methodsFor: 'instance creation' stamp: 'di 5/14/1998 09:43'!
openBrowserView: aBrowserView label: aString
    "Schedule aBrowserView, labelling the view aString."

    aBrowserView isMorph
        ifTrue:  [(aBrowserView setLabel: aString) openInWorld]
        ifFalse: [aBrowserView label: aString.
                aBrowserView minimumSize: 300 @ 200.
                aBrowserView subViews do: [:each | each controller].
                aBrowserView controller open]! !

!Browser class methodsFor: 'instance creation' stamp: 'tk 4/6/98 21:44'!
openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString
    "Create and schedule a message browser for the class, aBehavior, in
    which the argument, aString, contains characters to be edited in the text
    view. These characters are the source code for the message selector
    aSymbol."

    | newBrowser |
    (newBrowser _ Browser new) setClass: aBehavior selector: aSymbol.
    ^ Browser openBrowserView: (newBrowser openMessageEditString: aString)
        label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName
! !


!Browser class methodsFor: 'class initialization'!
initialize
        "Browser initialize"

        RecentClasses := OrderedCollection new! !
Switch subclass: #Button
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Menus'!
!Button commentStamp: 'di 5/22/1998 16:32' prior: 0!
Button comment:
'I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.'!


!Button methodsFor: 'state'!
turnOff
    "Sets the state of the receiver to 'off'. The off action of the receiver is not
    executed."

    on _ false! !

!Button methodsFor: 'state'!
turnOn
    "The receiver remains in the 'off' state'."

    self doAction: onAction.
    self doAction: offAction! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Button class
    instanceVariableNames: ''!

!Button class methodsFor: 'instance creation'!
newOn
    "Refer to the comment in Switch|newOn."

    self error: 'Buttons cannot be created in the on state'.
    ^nil! !
SimpleButtonMorph subclass: #ButtonMorph
    instanceVariableNames: 'lastAcceptedScript lastScriptEditor '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Experimental-Miscellaneous'!

!ButtonMorph methodsFor: 'menu' stamp: 'di 11/4/97 09:01'!
addCustomMenuItems: aCustomMenu hand: aHandMorph
    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    aCustomMenu add: 'border color' action: #changeBorderColor:.
    aCustomMenu add: 'border width' action: #changeBorderWidth:.
    aCustomMenu add: 'change label' action: #setLabel.
    aCustomMenu add: 'script' action: #editScript:.
! !

!ButtonMorph methodsFor: 'menu'!
editScript: evt

    self nameInModel ifNil: [self choosePartNameSilently].
    evt hand attachMorph:
        (self scriptEditorFor: 'buttonUp').
! !

!ButtonMorph methodsFor: 'menu'!
hasScript
    "Return true if there is already a script for this morph."

    ^ lastAcceptedScript ~~ nil! !

!ButtonMorph methodsFor: 'menu'!
scriptEditorFor: ignored

    (lastScriptEditor ~= nil and: [lastScriptEditor isInWorld])
        ifTrue: [^ lastScriptEditor].

    lastAcceptedScript = nil ifTrue: [
        ^ lastScriptEditor _ ScriptEditorMorph new
            setMorph: self
            scriptName: 'ButtonUp'.
    ] ifFalse: [
        ^ lastScriptEditor _ lastAcceptedScript fullCopy].
! !


!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:22'!
copy

    | obj |
    obj _ super copy.
    obj lastScriptEditor: obj lastAcceptedScript.
        "lastScriptEditor would not have been copied, as it is owned by the world, not me.  Can't allow mine to creep into the copy."
    ^ obj! !

!ButtonMorph methodsFor: 'copying' stamp: 'sw 9/22/97 08:57'!
copyRecordingIn: dict
    "Overridden to copy lastAcceptedScript as well."

    | new |
    new _ super copyRecordingIn: dict.
    lastAcceptedScript ifNotNil: [
        new lastAcceptedScript:
            ((dict includesKey: lastAcceptedScript)
                ifTrue: [dict at: lastAcceptedScript]
                ifFalse: [lastAcceptedScript copyRecordingIn: dict])].
    lastScriptEditor ifNotNil: [
        new lastScriptEditor:
            ((dict includesKey: lastScriptEditor)
                ifTrue: [dict at: lastScriptEditor]
                ifFalse: [lastScriptEditor copyRecordingIn: dict])].
    ^ new
! !

!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:23'!
prepareToBeSaved
    "SmartRefStream will not write any morph that is owned by someone outside the root being written.  (See DataStream.typeIDFor:)  Open Scripts are like that.  Make a private copy of the scriptEditor."

    super prepareToBeSaved.
    lastAcceptedScript ifNotNil: [
        lastAcceptedScript owner ifNotNil: ["open on the screen"
            lastAcceptedScript _ lastAcceptedScript fullCopy setMorph: self.
            "lastAcceptedScript privateOwner: nil" "fullCopy does it"]].
    "lastScriptEditor will not be written out"! !

!ButtonMorph methodsFor: 'copying' stamp: 'tk 12/4/97 11:21'!
shallowCopy

    | obj |
    obj _ super shallowCopy.
    obj lastScriptEditor: obj lastAcceptedScript.
        "lastScriptEditor would not have been copied, as it is owned by the world, not me.  Can't allow mine to creep into the copy."
    ^ obj! !


!ButtonMorph methodsFor: 'other'!
acceptScript: aScriptEditorMorph for: ignored

    lastAcceptedScript _ aScriptEditorMorph.
    self world model class
        compile: lastAcceptedScript methodString
        classified: 'scripts'
        notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
buttonUpSelector

    ^ (self nameInModel, 'ButtonUp') asSymbol
! !

!ButtonMorph methodsFor: 'other'!
choosePartName
    "Override to add null on-ticks script when this morph is named."

    | newName |
    newName _ super choosePartName.
    newName ifNil: [^ self].  "user cancelled or chose a bad part name"
    (self world model class)
        compile: self buttonUpSelector
        classified: 'scripts'
        notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
choosePartNameSilently

    super choosePartNameSilently.
    (self world model class)
        compile: self buttonUpSelector
        classified: 'scripts'
        notifying: nil.
! !

!ButtonMorph methodsFor: 'other'!
doButtonAction

    self nameInModel ~~ nil ifTrue: [
        self world model perform: self buttonUpSelector].
! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 12/4/97 11:22'!
lastAcceptedScript
    ^ lastAcceptedScript! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'!
lastAcceptedScript: scriptEditor
    "Need to do a clean store here."

    lastAcceptedScript _ scriptEditor! !

!ButtonMorph methodsFor: 'other' stamp: 'tk 9/21/97 00:16'!
lastScriptEditor: scriptEditor
    "Need to do a clean store here."

    lastScriptEditor _ scriptEditor! !
ArrayedCollection variableByteSubclass: #ByteArray
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Collections-Arrayed'!
!ByteArray commentStamp: 'di 5/22/1998 16:32' prior: 0!
ByteArray comment:
'I represent an ArrayedCollection whose elements can only be integers between 0 and 255. They are stored two bytes to a word.'!


!ByteArray methodsFor: 'accessing'!
asString
    "Convert to a String with Characters for each byte.
    Fast code uses primitive that avoids character conversion"

    ^ (String new: self size) replaceFrom: 1 to: self size with: self! !

!ByteArray methodsFor: 'accessing'!
doubleWordAt: i
    "Answer the value of the double word (4 bytes) starting at byte index i."

    | b0 b1 b2 w |
    "Primarily for reading socket #s in Pup headers"
    b0 _ self at: i.
    b1 _ self at: i+1.
    b2 _ self at: i+2.
    w _ self at: i+3.
    "Following sequence minimizes LargeInteger arithmetic for small results."
    b2=0 ifFalse: [w _ (b2 bitShift: 8) + w].
    b1=0 ifFalse: [w _ (b1 bitShift: 16) + w].
    b0=0 ifFalse: [w _ (b0 bitShift: 24) + w].
    ^w! !

!ByteArray methodsFor: 'accessing'!
doubleWordAt: i put: value
    "Set the value of the double word (4 bytes) starting at byte index i."

    | w |
    "Primarily for setting socket #s in Pup headers"
    w _ value asInteger.
    self at: i put: (w digitAt: 4).
    self at: i + 1 put: (w digitAt: 3).
    self at: i + 2 put: (w digitAt: 2).
    self at: i + 3 put: (w digitAt: 1)! !

!ByteArray methodsFor: 'accessing'!
wordAt: i
    "Answer the value of the word (2 bytes) starting at index i."

    | j |
    j _ i + i.
    ^((self at: j - 1) bitShift: 8) + (self at: j)! !

!ByteArray methodsFor: 'accessing'!
wordAt: i put: v
    "Set the value of the word (2 bytes) starting at index i."

    | j |
    j _ i + i.
    self at: j - 1 put: ((v bitShift: -8) bitAnd: 8r377).
    self at: j put: (v bitAnd: 8r377)! !


!ByteArray methodsFor: 'private'!
defaultElement

    ^0! !

!ByteArray methodsFor: 'private'!
replaceFrom: start to: stop with: replacement startingAt: repStart
    "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive."
    <primitive: 105>
    super replaceFrom: start to: stop with: replacement startingAt: repStart! !
Object subclass: #CCodeGenerator
    instanceVariableNames: 'translationDict inlineList constants variables variableDeclarations methods variablesSetCache '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Squeak-Translation to C'!
!CCodeGenerator commentStamp: 'di 5/22/1998 16:32' prior: 0!
CCodeGenerator comment:
'This class oversees the translation of a subset of Smalltalk to C, allowing the comforts of Smalltalk during development and the efficiency and portability of C for the resulting interpreter.  Executing

    Interpreter translate: ''InterpTest.c'' doInlining: true.

(with single quotes) will cause all the methods of Interpreter, ObjectMemory and BitBltSimulation to be translated to C, and stored in the named file.  This file together with the files emitted by InterpreterSupportCode (qv) should be adequate to produce a complete interpreter for the Macintosh environment.'!


!CCodeGenerator methodsFor: 'public' stamp: 'ikp 12/4/97 23:01'!
addClass: aClass
    "Add the variables and methods of the given class to the code base."
    | source |
    self checkClassForNameConflicts: aClass.
    aClass classPool associationsDo: [ :assoc |
        constants at: assoc key put: (TConstantNode new setValue: assoc value).
    ].
    "ikp..."
    aClass sharedPools do: [:pool |
        pool associationsDo: [ :assoc |
            constants at: assoc key put: (TConstantNode new setValue: assoc value).
        ].
    ].
    variables addAll: aClass instVarNames.
'Adding Class ' , aClass name , '...'
displayProgressAt: Sensor cursorPoint
from: 0 to: aClass selectors size
during: [:bar |
    aClass selectors doWithIndex: [ :sel :i | bar value: i.
        source _ aClass sourceCodeAt: sel.
        self addMethod: ((Compiler new parse: source in: aClass notifying: nil) asTMethodFromClass: aClass).
    ]].! !

!CCodeGenerator methodsFor: 'public' stamp: 'jm 1/5/98 16:36'!
addClassVarsFor: aClass
    "Add the class variables for the given class (and its superclasses) to the code base as constants."

    | allClasses |
    allClasses _ aClass allSuperclasses asOrderedCollection.
    allClasses add: aClass.
    allClasses do: [:c |
        c classPool associationsDo:
            [:assoc | constants at: assoc key put: (TConstantNode new setValue: assoc value)]].
! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:48'!
codeString
    "Return a string containing all the C code for the code base. Used for testing."

    | stream |
    stream _ ReadWriteStream on: (String new: 1000).
    self emitCCodeOn: stream doInlining: true doAssertions: true.
    ^stream contents! !

!CCodeGenerator methodsFor: 'public' stamp: 'jm 2/15/98 18:26'!
codeStringForPrimitives: classAndSelectorList

    | sel aClass source s verbose meth |
    self initialize.
    classAndSelectorList do: [:classAndSelector |
        aClass _ Smalltalk at: (classAndSelector at: 1).
        self addClassVarsFor: aClass.
        sel _ classAndSelector at: 2.
        (aClass includesSelector: sel)
            ifTrue: [source _ aClass sourceCodeAt: sel]
            ifFalse: [source _ aClass class sourceCodeAt: sel].
        meth _ ((Compiler new parse: source in: aClass notifying: nil)
                asTMethodFromClass: aClass).
        meth primitive > 0 ifTrue: [meth preparePrimitiveInClass: aClass].
        "for old-style array accessing:
            meth covertToZeroBasedArrayReferences."
        meth replaceSizeMessages.
        self addMethod: meth].

    "method preparation"
    verbose _ false.
    self prepareMethods.
    verbose ifTrue: [
        self printUnboundCallWarnings.
        self printUnboundVariableReferenceWarnings.
        Transcript cr].

    "code generation"
    self doInlining: true.
    s _ ReadWriteStream on: (String new: 1000).
    methods _ methods asSortedCollection: [:m1 :m2 | m1 selector < m2 selector].
    self emitCHeaderForPrimitivesOn: s.
    self emitCVariablesOn: s.
    self emitCFunctionPrototypesOn: s.
    methods do: [:m | m emitCCodeOn: s generator: self].
    ^ s contents
! !

!CCodeGenerator methodsFor: 'public'!
globalsAsSet
    "Used by the inliner to avoid name clashes with global variables."

    ((variablesSetCache == nil) or:
     [variablesSetCache size ~= variables size]) ifTrue: [
        variablesSetCache _ variables asSet.
    ].
    ^ variablesSetCache! !

!CCodeGenerator methodsFor: 'public'!
initialize

    translationDict _ Dictionary new.
    inlineList _ Array new.
    constants _ Dictionary new.
    variables _ OrderedCollection new.
    variableDeclarations _ Dictionary new.
    methods _ Dictionary new.
    self initializeCTranslationDictionary.! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag
    "Store C code for this code base on the given file."

    self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: true! !

!CCodeGenerator methodsFor: 'public' stamp: 'ikp 9/26/97 14:50'!
storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: assertionFlag
    "Store C code for this code base on the given file."

    | stream |
    stream _ FileStream newFileNamed: fileName.
    self emitCCodeOn: stream doInlining: inlineFlag doAssertions: assertionFlag.
    stream close.! !

!CCodeGenerator methodsFor: 'public'!
var: varName declareC: declarationString
    "Record the given C declaration for a global variable."

    variableDeclarations at: varName put: declarationString.! !


!CCodeGenerator methodsFor: 'error notification' stamp: 'ikp 12/4/97 22:56'!
checkClassForNameConflicts: aClass
    "Verify that the given class does not have constant, variable, or method names that conflict with those of previously added classes. Raise an error if a conflict is found, otherwise just return."

    "check for constant name collisions"
    aClass classPool associationsDo: [ :assoc |
        (constants includesKey: assoc key) ifTrue: [
            self error: 'Constant was defined in a previously added class: ', assoc key.
        ].
    ].
    "ikp..."
    aClass sharedPools do: [:pool |
        pool associationsDo: [ :assoc |
            (constants includesKey: assoc key) ifTrue: [
                self error: 'Constant was defined in a previously added class: ', assoc key.
            ].
        ].
    ].

    "check for instance variable name collisions"
    aClass instVarNames do: [ :varName |
        (variables includes: varName) ifTrue: [
            self error: 'Instance variable was defined in a previously added class: ', varName.
        ].
    ].

    "check for method name collisions"
    aClass selectors do: [ :sel |
        (methods includesKey: sel) ifTrue: [
            self error: 'Method was defined in a previously added class: ', sel.
        ].
    ].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundCallWarnings
    "Print a warning message for every unbound method call in the code base."

    | knownSelectors undefinedCalls |
    undefinedCalls _ Dictionary new.
    knownSelectors _ translationDict keys asSet.
    knownSelectors add: #error:.
    methods do: [ :m | knownSelectors add: m selector ].
    methods do: [ :m |
        m allCalls do: [ :sel |
            (knownSelectors includes: sel) ifFalse: [
                (undefinedCalls includesKey: sel)
                    ifTrue: [ (undefinedCalls at: sel) add: m selector ]
                    ifFalse: [ undefinedCalls at: sel put: (OrderedCollection with: m selector) ].
            ].
        ].
    ].

    Transcript cr.
    undefinedCalls keys asSortedCollection do: [ :undefined |
        Transcript show: undefined, ' -- undefined method sent by:'; cr.
        (undefinedCalls at: undefined) do: [ :caller |
            Transcript tab; show: caller; cr.
        ].
    ].! !

!CCodeGenerator methodsFor: 'error notification'!
printUnboundVariableReferenceWarnings
    "Print a warning message for every unbound variable reference in the code base."

    | undefinedRefs globalVars knownVars |
    undefinedRefs _ Dictionary new.
    globalVars _ Set new: 100.
    globalVars addAll: variables.
    methods do: [ :m |
        knownVars _ globalVars copy.
        m args do: [ :var | knownVars add: var ].
        m locals do: [ :var | knownVars add: var ].
        m freeVariableReferences do: [ :varName |
            (knownVars includes: varName) ifFalse: [
                (undefinedRefs includesKey: varName)
                    ifTrue: [ (undefinedRefs at: varName) add: m selector ]
                    ifFalse: [ undefinedRefs at: varName put: (OrderedCollection with: m selector) ].
            ].
        ].
    ].

    Transcript cr.
    undefinedRefs keys asSortedCollection do: [ :var |
        Transcript show: var, ' -- undefined variable used in:'; cr.
        (undefinedRefs at: var) do: [ :sel |
            Transcript tab; show: sel; cr.
        ].
    ].! !


!CCodeGenerator methodsFor: 'inlining'!
collectInlineList
    "Make a list of methods that should be inlined."
    "Details: The method must not include any inline C, since the translator cannot currently map variable names in inlined C code. Methods to be inlined must be small or called from only one place."

    | methodsNotToInline callsOf inlineIt hasCCode nodeCount senderCount |
    methodsNotToInline _ Set new: methods size.

    "build dictionary to record the number of calls to each method"
    callsOf _ Dictionary new: methods size * 2.
    methods keys do: [ :sel | callsOf at: sel put: 0 ].

    "For each method, scan its parse tree once to:
        1. determine if the method contains C code or declarations
        2. determine how many nodes it has
        3. increment the sender counts of the methods it calls
        4. determine if it includes any C declarations or code"
    inlineList _ Set new: methods size * 2.
    methods do: [ :m |
        inlineIt _ #dontCare.
        (translationDict includesKey: m selector) ifTrue: [
            hasCCode _ true.
        ] ifFalse: [
            hasCCode _ m declarations size > 0.
            nodeCount _ 0.
            m parseTree nodesDo: [ :node |
                node isSend ifTrue: [
                    sel _ node selector.
                    sel = #cCode: ifTrue: [ hasCCode _ true ].
                    senderCount _ callsOf at: sel ifAbsent: [ nil ].
                    nil = senderCount ifFalse: [
                        callsOf at: sel put: senderCount + 1.
                    ].
                ].
                nodeCount _ nodeCount + 1.
            ].
            inlineIt _ m extractInlineDirective.  "may be true, false, or #dontCare"
        ].
        (hasCCode or: [inlineIt = false]) ifTrue: [
            "don't inline if method has C code and is contains negative inline directive"
            methodsNotToInline add: m selector.
        ] ifFalse: [
            ((nodeCount < 40) or: [inlineIt = true]) ifTrue: [
                "inline if method has no C code and is either small or contains inline directive"
                inlineList add: m selector.
            ].
        ].
    ].

    callsOf associationsDo: [ :assoc |
        ((assoc value = 1) and: [(methodsNotToInline includes: assoc key) not]) ifTrue: [
            inlineList add: assoc key.
        ].
    ].! !

!CCodeGenerator methodsFor: 'inlining'!
doInlining
    "Inline the bodies of all methods that are suitable for inlining."
    "Interpreter translate: 'InterpTest.c' doInlining: true"

    | pass progress |
    self collectInlineList.
    "xxx do we need the following?"
    Interpreter primitiveTable do: [ :sel |
        inlineList remove: sel ifAbsent: [].
    ].

    pass _ 0.
    progress _ true.
    [progress] whileTrue: [
        "repeatedly attempt to inline methods until no further progress is made"
        progress _ false.
        ('Inlining pass ', (pass _ pass + 1) printString, '...')
            displayProgressAt: Sensor cursorPoint
            from: 0 to: methods size
            during: [ :bar |
                methods doWithIndex: [ :m :i |
                    bar value: i.
                    (m tryToInlineMethodsIn: self)
                        ifTrue: [progress _ true]]].
    ].
    'Inlining bytecodes'
        displayProgressAt: Sensor cursorPoint
        from: 1 to: 2
        during: [ :bar |
            self inlineDispatchesInMethodNamed: #interpret
                localizingVars: #(currentBytecode localIP localSP).
            bar value: 1.
            self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP)
                except: #interpret.
            bar value: 2.
    ].
! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 1/3/98 23:13'!
doInlining: inlineFlag
    "Inline the bodies of all methods that are suitable for inlining."
    "Modified slightly for the translator, since the first level of inlining for the interpret
    loop must be performed in order that the instruction implementations can easily
    discover their addresses."

    "Interpreter translate: 'InterpTest.c' doInlining: true"

    | pass progress |

    inlineFlag ifFalse: [
        ^self inlineDispatchesInMethodNamed: #interpret localizingVars: #().
    ].

    self collectInlineList.
    "xxx do we need the following?"
    Interpreter primitiveTable do: [ :sel |
        inlineList remove: sel ifAbsent: [].
    ].

    pass _ 0.
    progress _ true.
    [progress] whileTrue: [
        "repeatedly attempt to inline methods until no further progress is made"
        progress _ false.
        ('Inlining pass ', (pass _ pass + 1) printString, '...')
            displayProgressAt: Sensor cursorPoint
            from: 0 to: methods size
            during: [ :bar |
                methods doWithIndex: [ :m :i |
                    bar value: i.
                    (m tryToInlineMethodsIn: self)
                        ifTrue: [progress _ true]]].
    ].
    'Inlining bytecodes'
        displayProgressAt: Sensor cursorPoint
        from: 1 to: 3
        during: [ :bar |
            self inlineDispatchesInMethodNamed: #interpret
                localizingVars: #(currentBytecode localIP localSP localCP localTP).
            bar value: 1.
"xxx
            (methods includesKey: #translateNewMethod) ifTrue:
                [self inlineDispatchesInMethodNamed: #translateNewMethod
                    localizingVars: #(currentByte bytePointer opPointer).
                self removeMethodsReferingToGlobals: #(currentByte bytePointer opPointer)
                    except: #translateNewMethod.
                ].
xxx"
            bar value: 2.
            self removeMethodsReferingToGlobals: #(currentBytecode localIP localSP localCP localTP)
                except: #interpret.
            bar value: 3.
    ].
! !

!CCodeGenerator methodsFor: 'inlining'!
inlineDispatchesInMethodNamed: selector localizingVars: varsList
    "Inline dispatches (case statements) in the method with the given name."

    | m |
    m _ self methodNamed: selector.
    m = nil ifFalse: [
        m inlineCaseStatementBranchesIn: self localizingVars: varsList.
        m parseTree nodesDo: [ :n |
            n isCaseStmt ifTrue: [
                n customizeShortCasesForDispatchVar: #currentBytecode.
            ].
        ].
    ].
    variables _ variables asOrderedCollection.
    varsList do: [ :v |
        variables remove: v asString ifAbsent: [].
        (variableDeclarations includesKey: v asString) ifTrue: [
            m declarations at: v asString put: (variableDeclarations at: v asString).
            variableDeclarations removeKey: v asString.
        ].
    ].
! !

!CCodeGenerator methodsFor: 'inlining'!
mayInline: sel
    "Answer true if the method with the given selector may be inlined."

    ^ inlineList includes: sel! !

!CCodeGenerator methodsFor: 'inlining'!
methodStatsString
    "Return a string describing the size, # of locals, and # of senders of each method. Note methods that have inline C code or C declarations."

    | methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s calls registers selr |
    methodsWithCCode _ Set new: methods size.
    sizesOf _ Dictionary new: methods size * 2.  "selector -> nodeCount"
    callsOf _ Dictionary new: methods size * 2.  "selector -> senderCount"

    "For each method, scan its parse tree once to:
        1. determine if the method contains C code or declarations
        2. determine how many nodes it has
        3. increment the sender counts of the methods it calls
        4. determine if it includes any C declarations or code"

    methods do: [ :m |
        (translationDict includesKey: m selector) ifTrue: [
            hasCCode _ true.
        ] ifFalse: [
            hasCCode _ m declarations size > 0.
            nodeCount _ 0.
            m parseTree nodesDo: [ :node |
                node isSend ifTrue: [
                    selr _ node selector.
                    selr = #cCode: ifTrue: [ hasCCode _ true ].
                    senderCount _ callsOf at: selr ifAbsent: [ 0 ].
                    callsOf at: selr put: senderCount + 1.
                ].
                nodeCount _ nodeCount + 1.
            ].
        ].
        hasCCode ifTrue: [ methodsWithCCode add: m selector ].
        sizesOf at: m selector put: nodeCount.
    ].

    s _ WriteStream on: (String new: 5000).
    methods keys asSortedCollection do: [ :sel |
        m _ methods at: sel.
        registers _ m locals size + m args size.
        calls _ callsOf at: sel ifAbsent: [0].
        registers > 11 ifTrue: [
            s nextPutAll: sel; tab.
            s nextPutAll: (sizesOf at: sel) printString; tab.
            s nextPutAll: calls printString; tab.
            s nextPutAll: registers printString; tab.
            (methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ].
        s cr.
        ].
    ].
    ^ s contents! !

!CCodeGenerator methodsFor: 'inlining' stamp: 'ikp 9/26/97 14:50'!
removeAssertions
    "Remove all assertions in method bodies.  This is for the benefit of inlining, which
    fails to recognise and disregard empty method bodies when checking the inlinability
    of sends."

    | newMethods |
    newMethods _ Dictionary new.
    'Removing assertions...'
        displayProgressAt: Sensor cursorPoint
        from: 0 to: methods size
        during: [ :bar |
            methods doWithIndex: [ :m :i |
                bar value: i.
                m isAssertion ifFalse: [
                    newMethods at: m selector put: m.
                    m removeAssertions]]].
    methods _ newMethods.! !

!CCodeGenerator methodsFor: 'inlining'!
removeMethodsReferingToGlobals: varList except: methodName
    "Remove any methods (presumably inlined) that still contain references to the given obsolete global variables."

    | varListAsStrings removeIt mVars |
    varListAsStrings _ varList collect: [ :sym | sym asString ].
    methods keys copy do: [ :sel |
        removeIt _ false.
        mVars _ (self methodNamed: sel) freeVariableReferences asSet.
        varListAsStrings do: [ :v |
            (mVars includes: v) ifTrue: [ removeIt _ true ].
        ].
        (removeIt and: [sel ~= methodName]) ifTrue: [
            methods removeKey: sel ifAbsent: [].
        ].
    ].! !


!CCodeGenerator methodsFor: 'utilities'!
addMethod: aTMethod
    "Add the given method to the code base."

    (methods includesKey:  aTMethod selector) ifTrue: [
        self error: 'Method name conflict: ', aTMethod selector.
    ].
    methods at: aTMethod selector put: aTMethod.! !

!CCodeGenerator methodsFor: 'utilities'!
builtin: sel
    "Answer true if the given selector is one of the builtin selectors."

    ((sel = #longAt:) or: [(sel = #longAt:put:) or: [sel = #error:]]) ifTrue: [ ^true ].
    ((sel = #byteAt:) or: [sel = #byteAt:put:]) ifTrue: [ ^true ].
    ^translationDict includesKey: sel! !

!CCodeGenerator methodsFor: 'utilities'!
cCodeForMethod: selector
    "Answer a string containing the C code for the given method."
    "Example:
        ((CCodeGenerator new initialize addClass: TestCClass1; prepareMethods)
            cCodeForMethod: #ifTests)"

    | m s |
    m _ self methodNamed: selector.
    m = nil ifTrue: [ self error: 'method not found in code base: ', selector ].

    s _ (ReadWriteStream on: '').
    m emitCCodeOn: s generator: self.
    ^ s contents! !

!CCodeGenerator methodsFor: 'utilities'!
emitBuiltinConstructFor: msgNode on: aStream level: level
    "If the given selector is in the translation dictionary, translate it into a target code construct and return true. Otherwise, do nothing and return false."

    | action |
    action _ translationDict at: msgNode selector ifAbsent: [ ^false ].
    self perform: action with: msgNode with: aStream with: level.
    ^true! !

!CCodeGenerator methodsFor: 'utilities'!
methodNamed: selector
    "Answer the method in the code base with the given selector."

    ^ methods at: selector ifAbsent: [ nil ]! !

!CCodeGenerator methodsFor: 'utilities'!
methodsReferringToGlobal: v
    "Return a collection of methods that refer to the given global variable."

    | out |
    out _ OrderedCollection new.
    methods associationsDo: [ :assoc |
        (assoc value freeVariableReferences includes: v) ifTrue: [
            out add: assoc key.
        ].
    ].
    ^ out! !

!CCodeGenerator methodsFor: 'utilities'!
methodsThatCanInvoke: aSelectorList
    "Return a set of methods that can invoke one of the given selectors, either directly or via a sequence of intermediate methods."

    | out todo sel mSelector |
    out _ Set new.
    todo _ aSelectorList copy asOrderedCollection.
    [todo isEmpty] whileFalse: [
        sel _ todo removeFirst.
        out add: sel.
        methods do: [ :m |
            (m allCalls includes: sel) ifTrue: [
                mSelector _ m selector.
                ((out includes: mSelector) or:
                 [todo includes: mSelector]) ifFalse: [
                    todo add: mSelector.
                ].
            ].
        ].
    ].
    ^ out
    ! !

!CCodeGenerator methodsFor: 'utilities'!
prepareMethods
    "Prepare methods for browsing."

    | globals |
    globals _ Set new: 200.
    globals addAll: variables.
    methods do: [ :m |
        (m locals, m args) do: [ :var |
            (globals includes: var) ifTrue: [
                self error: 'Local variable name may mask global when inlining: ', var.
            ].
            (methods includesKey: var) ifTrue: [
                self error: 'Local variable name may mask method when inlining: ', var.
            ].
        ].
        m bindClassVariablesIn: constants.
        m prepareMethodIn: self.
    ].! !

!CCodeGenerator methodsFor: 'utilities'!
reportRecursiveMethods
    "Report in transcript all methods that can call themselves directly or indirectly or via a chain of N intermediate methods."

    | visited calls newCalls sel called |
    methods do: [: m |
        visited _ translationDict keys asSet.
        calls _ m allCalls asOrderedCollection.
        5 timesRepeat: [
            newCalls _ Set new: 50.
            [calls isEmpty] whileFalse: [
                sel _ calls removeFirst.
                sel = m selector ifTrue: [
                    Transcript show: m selector, ' is recursive'; cr.
                ] ifFalse: [
                    (visited includes: sel) ifFalse: [
                        called _ self methodNamed: sel.
                        called = nil ifFalse: [ newCalls addAll: called allCalls ].
                    ].
                    visited add: sel.
                ].
            ].
            calls _ newCalls asOrderedCollection.
        ].
    ].! !

!CCodeGenerator methodsFor: 'utilities'!
unreachableMethods
    "Return a collection of methods that are never invoked."

    | sent out |
    sent _ Set new.
    methods do: [ :m |
        sent addAll: m allCalls.
    ].

    out _ OrderedCollection new.
    methods keys do: [ :sel |
        (sent includes: sel) ifFalse: [ out add: sel ].
    ].
    ^ out! !


!CCodeGenerator methodsFor: 'C code generator'!
cFunctionNameFor: aSelector
    "Create a C function name from the given selector by omitting colons."

    ^aSelector copyWithout: $:! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/2/97 19:40'!
cLiteralFor: anObject
    "Return a string representing the C literal value for the given object."
    | s |
    (anObject isKindOf: Integer) ifTrue: [
        (anObject < 16r7FFFFFFF)
            ifTrue: [^ anObject printString]
            ifFalse: [^ anObject printString , 'U']].
    (anObject isKindOf: String) ifTrue: [^ '"', anObject, '"' ].
    (anObject isKindOf: Float) ifTrue: [^ anObject printString ].
    anObject == nil ifTrue: [^ 'null' ].
    anObject == true ifTrue: [^ '1' ].            "ikp"
    anObject == false ifTrue: [^ '0' ].            "ikp"
    self error:                                "ikp"
        'Warning: A Smalltalk literal could not be translated into a C constant: ', anObject printString.
    ^'"XXX UNTRANSLATABLE CONSTANT XXX"'! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'!
emitCCodeOn: aStream doInlining: inlineFlag

    self emitCCodeOn: aStream doInlining: inlineFlag doAssertions: true! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 12/7/97 20:54'!
emitCCodeOn: aStream doInlining: inlineFlag doAssertions: assertionFlag
    "Emit C code for all methods in the code base onto the given stream. All inlined method calls should already have been expanded."

    | verbose |
    "method preparation"
    verbose _ false.
    self prepareMethods.
    verbose ifTrue: [
        self printUnboundCallWarnings.
        self printUnboundVariableReferenceWarnings.
        Transcript cr.
    ].
    assertionFlag ifFalse: [ self removeAssertions ].
    self doInlining: inlineFlag.

    "code generation"
    methods _ methods asSortedCollection: [ :m1 :m2 | m1 selector < m2 selector ].
    self emitCHeaderOn: aStream.
    self emitCVariablesOn: aStream.
    self emitCFunctionPrototypesOn: aStream.
'Writing Translated Code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: methods size
during: [:bar |
    methods doWithIndex: [ :m :i | bar value: i.
        m emitCCodeOn: aStream generator: self.
]].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCExpression: aParseNode on: aStream
    "Emit C code for the expression described by the given parse node."

    aParseNode isLeaf ifTrue: [
        "omit parens"
        aParseNode emitCCodeOn: aStream level: 0 generator: self.
    ] ifFalse: [
        aStream nextPut: $(.
        aParseNode emitCCodeOn: aStream level: 0 generator: self.
        aStream nextPut: $).
    ].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCFunctionPrototypesOn: aStream
    "Store prototype declarations for all non-inlined methods on the given stream."

    aStream nextPutAll: '/*** Function Prototypes ***/'; cr.
    methods do: [ :m |
        m emitCFunctionPrototype: aStream generator: self.
        aStream nextPutAll: ';'; cr.
    ].! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'ikp 1/4/98 00:03'!
emitCHeaderForPrimitivesOn: aStream
    "Write a C file header for compiled primitives onto the given stream."

    aStream nextPutAll: '/* Automatically generated from Squeak on '.
    aStream nextPutAll: Time dateAndTimeNow printString.
    aStream nextPutAll: ' */'; cr; cr.

    aStream nextPutAll: '#include "sq.h"'; cr; cr.

    aStream nextPutAll: '
/* Memory Access Macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

/*** Imported Functions/Variables ***/
extern int stackValue(int);
extern int successFlag;
'.
    aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 2/1/98 15:35'!
emitCHeaderOn: aStream
    "Write a C file header onto the given stream."

    aStream nextPutAll: '/* Automatically generated from Squeak on '.
    aStream nextPutAll: Time dateAndTimeNow printString.
    aStream nextPutAll: ' */'; cr; cr.

    aStream nextPutAll: '#include "sq.h"'; cr.
    aStream nextPutAll: '#include "sqMachDep.h"  /* needed only by the JIT virtual machine */'; cr.

    aStream nextPutAll: '
/* memory access macros */
#define byteAt(i) (*((unsigned char *) (i)))
#define byteAtput(i, val) (*((unsigned char *) (i)) = val)
#define longAt(i) (*((int *) (i)))
#define longAtput(i, val) (*((int *) (i)) = val)

int printCallStack(void);
void error(char *s);
void error(char *s) {
    /* Print an error message and exit. */
    static int printingStack = false;

    printf("\n%s\n\n", s);
    if (!!printingStack) {
        /* flag prevents recursive error when trying to print a broken stack */
        printingStack = true;
        printCallStack();
    }
    exit(-1);
}
'.
    aStream cr.! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCTestBlock: aBlockNode on: aStream
    "Emit C code for the given block node to be used as a loop test."

    aBlockNode statements size > 1 ifTrue: [
        aBlockNode emitCCodeOn: aStream level: 0 generator: self.
    ] ifFalse: [
        aBlockNode statements first emitCCodeOn: aStream level: 0 generator: self.
    ].! !

!CCodeGenerator methodsFor: 'C code generator'!
emitCVariablesOn: aStream
    "Store the global variable declarations on the given stream."

    aStream nextPutAll: '/*** Variables ***/'; cr.
    variables asSortedCollection do: [ :var |
        (variableDeclarations includesKey: var) ifTrue: [
            aStream nextPutAll: (variableDeclarations at: var), ';'; cr.
        ] ifFalse: [
            "default variable declaration"
            aStream nextPutAll: 'int ', var, ';'; cr.
        ].
    ].
    aStream cr.! !


!CCodeGenerator methodsFor: 'C translation'!
generateAnd: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' && '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAt: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: '['.
    msgNode args first emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: ']'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateAtPut: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: '['.
    msgNode args first emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: '] = '.
    self emitCExpression: msgNode args last on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitAnd: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' & '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitInvert32: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '~'.
    self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitOr: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' | '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitShift: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    | arg rcvr |
    arg _ msgNode args first.
    rcvr _ msgNode receiver.
    arg isConstant ifTrue: [
        "bit shift amount is a constant"
        aStream nextPutAll: '((unsigned) '.
        self emitCExpression: rcvr on: aStream.
        arg value < 0 ifTrue: [
            aStream nextPutAll: ' >> ', arg value negated printString.
        ] ifFalse: [
            aStream nextPutAll: ' << ', arg value printString.
        ].
        aStream nextPutAll: ')'.
    ] ifFalse: [
        "bit shift amount is an expression"
        aStream nextPutAll: '(('.
        self emitCExpression: arg on: aStream.
        aStream nextPutAll: ' < 0) ? ((unsigned) '.
        self emitCExpression: rcvr on: aStream.
        aStream nextPutAll: ' >> -'.
        self emitCExpression: arg on: aStream.
        aStream nextPutAll: ') : ((unsigned) '.
        self emitCExpression: rcvr on: aStream.
        aStream nextPutAll: ' << '.
        self emitCExpression: arg on: aStream.
        aStream nextPutAll: '))'.
    ].! !

!CCodeGenerator methodsFor: 'C translation'!
generateBitXor: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' ^ '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateCCoercion: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '(('.
    aStream nextPutAll: msgNode args last value.
    aStream nextPutAll: ') '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ')'.

! !

!CCodeGenerator methodsFor: 'C translation'!
generateDivide: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' / '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateEqual: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' == '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThan: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' > '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateGreaterThanOrEqual: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' >= '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfFalse: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."
    "Note: PP 2.3 compiler produces two arguments for ifFalse:, presumably
     to help with inlining later. Taking the last agument should do the correct
     thing even if your compiler is different."

    aStream nextPutAll: 'if (!!('.
    msgNode receiver emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: ')) {'; cr.
    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfFalseIfTrue: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."
    "Note: PP 2.3 compiler reverses the argument blocks for ifFalse:ifTrue:,
       presumably to help with inlining later. That is, the first argument
       is the block to be evaluated if the condition is true."

    aStream nextPutAll: 'if ('.
    msgNode receiver emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: ') {'; cr.
    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '} else {'; cr.
    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfTrue: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: 'if ('.
    msgNode receiver emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: ') {'; cr.
    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIfTrueIfFalse: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: 'if ('.
    msgNode receiver emitCCodeOn: aStream level: level generator: self.
    aStream nextPutAll: ') {'; cr.
    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '} else {'; cr.
    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineCCode: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: msgNode args first value.! !

!CCodeGenerator methodsFor: 'C translation'!
generateInlineDirective: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '/* inline: '.
    aStream nextPutAll: msgNode args first name.
    aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerObjectOf: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '(('.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ' << 1) | 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIntegerValueOf: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '('.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ' >> 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsIntegerObject: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '('.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ' & 1)'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateIsNil: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' == '.
    aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThan: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' < '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateLessThanOrEqual: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' <= '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMax: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '(('.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' < '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ') ? '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ' : '.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMin: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '(('.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' < '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ') ? '.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' : '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateMinus: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' - '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateModulo: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' % '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNot: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '!!'.
    self emitCExpression: msgNode receiver on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotEqual: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' !!= '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateNotNil: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' !!= '.
    aStream nextPutAll: (self cLiteralFor: nil).! !

!CCodeGenerator methodsFor: 'C translation'!
generateOr: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' || '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePlus: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' + '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreDecrement: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    | varNode |
    varNode _ msgNode receiver.
    varNode isVariable
        ifFalse: [ self error: 'preDecrement can only be applied to variables' ].
    aStream nextPutAll: '--'.
    aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation'!
generatePreIncrement: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    | varNode |
    varNode _ msgNode receiver.
    varNode isVariable
        ifFalse: [ self error: 'preIncrement can only be applied to variables' ].
    aStream nextPutAll: '++'.
    aStream nextPutAll: varNode name.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialAnd: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' && ('.
    self emitCTestBlock: msgNode args first on: aStream.
    aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSequentialOr: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."
    "Note: PP 2.3 compiler produces two arguments for or:, presumably
     to help with inlining later. Taking the last agument should do the correct
     thing even if your compiler is different."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' || ('.
    self emitCTestBlock: msgNode args last on: aStream.
    aStream nextPutAll: ')'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateSharedCodeDirective: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '/* common code: '.
    aStream nextPutAll: msgNode args first value.
    aStream nextPutAll: ' */'.
! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftLeft: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' << '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateShiftRight: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: '((unsigned) '.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ')'.
    aStream nextPutAll: ' >> '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateTimes: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: ' * '.
    self emitCExpression: msgNode args first on: aStream.! !

!CCodeGenerator methodsFor: 'C translation'!
generateToByDo: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    | iterationVar |
    (msgNode args last args size = 1) ifFalse: [
        self error: 'wrong number of block arguments'.
    ].
    iterationVar _ msgNode args last args first.
    aStream nextPutAll: 'for (', iterationVar, ' = '.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: '; ', iterationVar, ' <= '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: '; ', iterationVar, ' += '.
    self emitCExpression: (msgNode args at: 2) on: aStream.
    aStream nextPutAll: ') {'; cr.
    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateToDo: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    | iterationVar |
    (msgNode args last args size = 1) ifFalse: [
        self error: 'wrong number of block arguments'.
    ].
    iterationVar _ msgNode args last args first.
    aStream nextPutAll: 'for (', iterationVar, ' = '.
    self emitCExpression: msgNode receiver on: aStream.
    aStream nextPutAll: '; ', iterationVar, ' <= '.
    self emitCExpression: msgNode args first on: aStream.
    aStream nextPutAll: '; ', iterationVar, '++) {'; cr.
    msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateWhileFalse: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: 'while (!!('.
    self emitCTestBlock: msgNode receiver on: aStream.
    aStream nextPutAll: ')) {'; cr.
    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation'!
generateWhileTrue: msgNode on: aStream indent: level
    "Generate the C code for this message onto the given stream."

    aStream nextPutAll: 'while ('.
    self emitCTestBlock: msgNode receiver on: aStream.
    aStream nextPutAll: ') {'; cr.
    msgNode args first emitCCodeOn: aStream level: level + 1 generator: self.
    level timesRepeat: [ aStream tab ].
    aStream nextPutAll: '}'.! !

!CCodeGenerator methodsFor: 'C translation' stamp: 'jm 2/15/98 17:07'!
initializeCTranslationDictionary
    "Initialize the dictionary mapping message names to actions for C code generation."

    | pairs |
    translationDict _ Dictionary new: 200.
    pairs _ #(
    #&                #generateAnd:on:indent:
    #|                #generateOr:on:indent:
    #and:            #generateSequentialAnd:on:indent:
    #or:            #generateSequentialOr:on:indent:
    #not            #generateNot:on:indent:

    #+                #generatePlus:on:indent:
    #-                #generateMinus:on:indent:
    #*                #generateTimes:on:indent:
    #//                #generateDivide:on:indent:
    #\\                #generateModulo:on:indent:
    #<<                #generateShiftLeft:on:indent:
    #>>                #generateShiftRight:on:indent:
    #min:            #generateMin:on:indent:
    #max:            #generateMax:on:indent:

    #bitAnd:        #generateBitAnd:on:indent:
    #bitOr:            #generateBitOr:on:indent:
    #bitXor:            #generateBitXor:on:indent:
    #bitShift:        #generateBitShift:on:indent:
    #bitInvert32    #generateBitInvert32:on:indent:

    #<                #generateLessThan:on:indent:
    #<=                #generateLessThanOrEqual:on:indent:
    #=                #generateEqual:on:indent:
    #>                #generateGreaterThan:on:indent:
    #>=                #generateGreaterThanOrEqual:on:indent:
    #~=                #generateNotEqual:on:indent:
    #==                #generateEqual:on:indent:
    #isNil            #generateIsNil:on:indent:
    #notNil            #generateNotNil:on:indent:

    #whileTrue:     #generateWhileTrue:on:indent:
    #whileFalse:    #generateWhileFalse:on:indent:
    #to:do:            #generateToDo:on:indent:
    #to:by:do:        #generateToByDo:on:indent:

    #ifTrue:        #generateIfTrue:on:indent:
    #ifFalse:        #generateIfFalse:on:indent:
    #ifTrue:ifFalse:    #generateIfTrueIfFalse:on:indent:
    #ifFalse:ifTrue:    #generateIfFalseIfTrue:on:indent:

    #at:                #generateAt:on:indent:
    #at:put:            #generateAtPut:on:indent:
    #basicAt:        #generateAt:on:indent:
    #basicAt:put:    #generateAtPut:on:indent:

    #integerValueOf:    #generateIntegerValueOf:on:indent:
    #integerObjectOf:    #generateIntegerObjectOf:on:indent:
    #isIntegerObject:     #generateIsIntegerObject:on:indent:
    #cCode:                #generateInlineCCode:on:indent:
    #cCoerce:to:            #generateCCoercion:on:indent:
    #preIncrement        #generatePreIncrement:on:indent:
    #preDecrement        #generatePreDecrement:on:indent:
    #inline:                #generateInlineDirective:on:indent:
    #sharedCodeNamed:inCase:    #generateSharedCodeDirective:on:indent:
    ).

    1 to: pairs size by: 2 do: [ :i |
        translationDict at: (pairs at: i) put: (pairs at: i + 1).
    ].! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CCodeGenerator class
    instanceVariableNames: ''!

!CCodeGenerator class methodsFor: 'removing from system' stamp: 'jm 5/16/1998 10:26'!
removeCompilerMethods
    "Before removing the C code generator classes from the system, use this method to remove the compiler node methods that support it. This avoids leaving dangling references to C code generator classes in the compiler node classes."

    ParseNode withAllSubclasses do: [ :nodeClass |
        nodeClass removeCategory: 'C translation'.
    ].
    Smalltalk at: #AbstractSound ifPresent: [:abstractSound |
         abstractSound class removeCategory: 'primitive generation'].
! !
SwikiAction subclass: #CachedSwikiAction
    instanceVariableNames: 'cacheDirectory cacheURL pwsURL '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!CachedSwikiAction commentStamp: 'di 5/22/1998 16:32' prior: 0!
CachedSwikiAction caches SwikiAction pages so that they can be served as plain HTML files (no embedded Squeak code) even by a native webServer.

You must edit three class methods in CachedSwikiAction to get it to serve appropriately.

* CachedSwikiAction class defaultCacheDirectory is where to store cached pages
* CachedSwikiAction class defaultCacheURL is the URL to precede cached pages
* CachedSwikiAction class defaultPWSURL is where the PWS is that can handle editing and searching.

!
]style[(25 12 201 45 34 39 38 37 61)f1,f1LSwikiAction Comment;,f1,f1LCachedSwikiAction class defaultCacheDirectory;,f1,f1LCachedSwikiAction class defaultCacheURL;,f1,f1LCachedSwikiAction class defaultPWSURL;,f1!


!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/18/98 12:44'!
restore: nameOfSwiki
    super restore: nameOfSwiki.
    self source: 'cswiki',(ServerAction pathSeparator).
    self cacheDirectory: (self class defaultCacheDirectory).
    self cacheURL: (self class defaultCacheURL).
    self pwsURL: (self class defaultPWSURL).
    self generate.
! !

!CachedSwikiAction methodsFor: 'save/restore' stamp: 'mjg 3/23/98 11:35'!
restoreNoGen: nameOfSwiki
    super restore: nameOfSwiki.
    self source: 'cswiki',(ServerAction pathSeparator).
    self cacheDirectory: (self class defaultCacheDirectory).
    self cacheURL: (self class defaultCacheURL).
    self pwsURL: (self class defaultPWSURL).
    "self generate."
! !


!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:41'!
browse: pageRef from: request
    "Just reply with a page in HTML format"

    | formattedPage |
    formattedPage _ pageRef copy.
    "Make a copy, then format the text."
    formattedPage formatted: (HTMLformatter swikify: pageRef text
            linkhandler: [:link | urlmap
                    linkForCache: link
                    from: request peerName
                    storingTo: OrderedCollection new]).
    request reply: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html')
            with: formattedPage).
! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:34'!
generate
    1 to: (urlmap pages size) do: [:ref |
        self generate: (urlmap atID: ref) from: 'Beginning'.].
    self generateRecent.
! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/26/98 12:39'!
generate: pageRef from: request
    "Just reply with a page in HTML format"

    | formattedPage peer cacheFile file|
    (request isKindOf: PWS)
    ifFalse: [(request isKindOf: String) ifTrue: [peer _ request] ifFalse: [peer _ ' ']]
    ifTrue: [peer _ request peerName].
    formattedPage _ pageRef copy.
    "Make a copy, then format the text."
    formattedPage formatted: (HTMLformatter swikify: pageRef text
            linkhandler: [:link | urlmap
                    linkForCache: link
                    from: peer
                    storingTo: OrderedCollection new]).
    cacheFile _ (self cacheDirectory),(self name),(ServerAction pathSeparator),(pageRef coreID),'.html'.
    (StandardFileStream isAFileNamed: cacheFile)
    ifTrue: [FileDirectory deleteFilePath: cacheFile].
    file _ FileStream fileNamed: cacheFile.
    file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source ,'page.html')
            with: formattedPage).
    file close.

! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/18/98 12:21'!
generateRecent
    | file |
    file _ FileStream fileNamed: (self cacheDirectory),(self name),(ServerAction pathSeparator),'recent.html'.
    file nextPutAll: (HTMLformatter evalEmbedded: (self fileContents: source, 'recent.html')
                    with: urlmap recentCache).
    file close.! !

!CachedSwikiAction methodsFor: 'URL processing' stamp: 'mjg 3/23/98 11:44'!
inputFrom: request
    "Take user's input and respond with a searchresult or store the edit"

    | coreRef page |
    coreRef _ request message size < 2
        ifTrue: ['1']
        ifFalse: [request message at: 2].
    coreRef = 'searchresult' ifTrue: [
        "If contains search string, do search"
        request reply: PWS crlf,
            (HTMLformatter evalEmbedded: (self fileContents: source, 'results.html')
                with: (urlmap searchCacheFor: (request fields at: 'searchFor' ifAbsent: ['nothing']))).
        ^ #return].
    (request fields includesKey: 'text') ifTrue: ["It's a response from an edit, so store the page"
        page _ urlmap
            storeID: coreRef
            text: (request fields at: 'text' ifAbsent: ['blank text'])
            from: request peerName.
        page user: request userID.  "Address is machine, user only if logged in"
        self generate: (urlmap atID: coreRef) from: request.
        self generateRecent.
        ^ self].    "return self means do serve the edited page afterwards"
    "oops, a new kind!!"
    Transcript show: 'Unknown data from client. '; show: request fields printString; cr.! !


!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory
    ^cacheDirectory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:39'!
cacheDirectory: directory
    cacheDirectory _ directory! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL
    ^cacheURL! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 11:44'!
cacheURL: urlString
    cacheURL _ urlString! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL
    ^pwsURL    ! !

!CachedSwikiAction methodsFor: 'access' stamp: 'mjg 3/18/98 12:44'!
pwsURL: urlString
    pwsURL _ urlString    ! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CachedSwikiAction class
    instanceVariableNames: ''!

!CachedSwikiAction class methodsFor: 'initialization' stamp: 'tk 5/21/1998 12:58'!
setUp: named
    | newAction |
    super setUp: named.
    newAction _ PWS actions at: named.
    newAction cacheDirectory: (self defaultCacheDirectory).
    newAction cacheURL: (self defaultCacheURL).
    newAction source: 'cswiki',(ServerAction pathSeparator).
    ^ newAction! !


!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheDirectory
    ^'Guz 7600:WebSTAR 2.0:'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultCacheURL
    ^'http://guzdial.cc.gatech.edu/'! !

!CachedSwikiAction class methodsFor: 'services' stamp: 'mjg 3/23/98 12:05'!
defaultPWSURL
    ^'http://guzdial.cc.gatech.edu:8080/'! !
Morph subclass: #CachingMorph
    instanceVariableNames: 'damageRecorder cacheCanvas '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Kernel'!
!CachingMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
CachingMorph comment:
'This morph can be used to cache the picture of a morph that takes a long time to draw. It should be used with judgement, however, since heavy use of caching can consume large amounts of memory.'!


!CachingMorph methodsFor: 'all'!
drawOn: aCanvas

    submorphs isEmpty ifTrue: [^ super drawOn: aCanvas].
! !

!CachingMorph methodsFor: 'all'!
fullDrawOn: aCanvas

    self updateCacheCanvasDepth: aCanvas depth.
    aCanvas image: cacheCanvas form at: self fullBounds origin.
! !

!CachingMorph methodsFor: 'all'!
imageForm

    self updateCacheCanvasDepth: Display depth.
    ^ cacheCanvas form offset: self fullBounds topLeft
! !

!CachingMorph methodsFor: 'all'!
initialize

    super initialize.
    color _ Color veryLightGray.
    damageRecorder _ DamageRecorder new.
! !

!CachingMorph methodsFor: 'all'!
invalidRect: damageRect
    "Record the given rectangle in the damage list."

    damageRecorder recordInvalidRect: (damageRect translateBy: self fullBounds origin negated).
    super invalidRect: damageRect.
! !

!CachingMorph methodsFor: 'all' stamp: 'jm 11/13/97 16:31'!
releaseCachedState

    super releaseCachedState.
    cacheCanvas _ nil.
! !

!CachingMorph methodsFor: 'all' stamp: 'jm 7/30/97 12:43'!
updateCacheCanvasDepth: depth
    "Update the cached image of the morphs being held by this hand."

    | myBnds rectList c |
    myBnds _ self fullBounds.
    (cacheCanvas == nil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [
        cacheCanvas _ FormCanvas extent: myBnds extent depth: depth.
        c _ cacheCanvas copyOffset: myBnds origin negated.
        ^ super fullDrawOn: c].

    "incrementally update the cache canvas"
    rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: myBnds extent).
    damageRecorder reset.
    rectList do: [:r |
        c _ cacheCanvas copyOrigin: myBnds origin negated clipRect: r.
        c fillColor: Color transparent.  "clear to transparent"
        super fullDrawOn: c].
! !
Object subclass: #Canvas
    instanceVariableNames: 'origin clipRect shadowDrawing '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Support'!
!Canvas commentStamp: 'di 5/22/1998 16:32' prior: 0!
Canvas comment:
'A canvas is a two-dimensional medium on which morphs are drawn in a device-independent manner. Canvases keep track of the origin and clipping rectangle, as well as the underlying drawing medium (such as a window, pixmap, or postscript script).

This kind of canvas does no drawing, and may be used as a "null canvas" to factor out drawing time during performance measurements.'!


!Canvas methodsFor: 'initialization'!
reset

    origin _ 0@0.                            "origin of the top-left corner of this cavas"
    clipRect _ (0@0 corner: 10000@10000).        "default clipping rectangle"
    shadowDrawing _ false.                    "draw translucent shadows when true"! !


!Canvas methodsFor: 'copying' stamp: 'jm 8/2/97 13:54'!
copy

    ^ self clone
! !

!Canvas methodsFor: 'copying'!
copyClipRect: aRectangle

    ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin)
! !

!Canvas methodsFor: 'copying'!
copyForShadowDrawingOffset: aPoint

    ^ (self copyOrigin: origin + aPoint clipRect: clipRect) setShadowDrawing! !

!Canvas methodsFor: 'copying'!
copyOffset: aPoint

    ^ self copyOrigin: origin + aPoint clipRect: clipRect! !

!Canvas methodsFor: 'copying'!
copyOffset: aPoint clipRect: sourceClip
    "Make a copy of me offset by aPoint, and further clipped
    by sourceClip, a rectangle in the un-offset coordinates"

    ^ self copyOrigin: aPoint + origin
        clipRect: ((sourceClip translateBy: origin) intersect: clipRect)! !

!Canvas methodsFor: 'copying'!
copyOrigin: aPoint clipRect: aRectangle
    "Return a copy of this canvas with the given origin. The clipping rectangle of this canvas is the intersection of the given rectangle and the receiver's current clipping rectangle. This allows the clipping rectangles of nested clipping morphs to be composed."

    ^ self copy
        setOrigin: aPoint
        clipRect: (clipRect intersect: aRectangle)! !


!Canvas methodsFor: 'accessing'!
clipRect
    ^ clipRect translateBy: origin negated! !

!Canvas methodsFor: 'accessing'!
depth

    ^ Display depth
! !

!Canvas methodsFor: 'accessing'!
origin

    ^ origin! !


!Canvas methodsFor: 'testing'!
isVisible: aRectangle
    "Optimization of: ^ clipRect intersects: (aRectangle translateBy: origin)"

    ^ ((aRectangle right + origin x) < clipRect left or:
      [(aRectangle left + origin x) > clipRect right or:
      [(aRectangle bottom + origin y) < clipRect top or:
      [(aRectangle top + origin y) > clipRect bottom]]]) not
! !


!Canvas methodsFor: 'drawing'!
fillColor: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
fillOval: r color: c

    self fillOval: r color: c borderWidth: 0 borderColor: Color transparent.
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
fillOval: r color: c borderWidth: borderWidth borderColor: borderColor
    "Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing'!
fillRectangle: r color: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor
    "Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor
    "Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:08'!
frameOval: r color: c

    self fillOval: r color: Color transparent borderWidth: 1 borderColor: c.
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 14:10'!
frameOval: r width: w color: c

    self fillOval: r color: Color transparent borderWidth: w borderColor: c.
! !

!Canvas methodsFor: 'drawing'!
frameRectangle: r color: c

    self frameRectangle: r width: 1 color: c.
! !

!Canvas methodsFor: 'drawing'!
frameRectangle: r width: w color: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
image: i at: aPoint
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 7/28/97 14:30'!
image: aForm at: aPoint sourceRect: sourceRect rule: rule
    "Noop here; overridden by non-trivial canvases."
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
line: pt1 to: pt2 color: c

    self line: pt1 to: pt2 width: 1 color: c.
! !

!Canvas methodsFor: 'drawing'!
line: pt1 to: pt2 width: w color: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
paragraph: paragraph bounds: bounds color: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing'!
point: p color: c
    "Noop here; overridden by non-trivial canvases."! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
text: s at: pt font: fontOrNil color: c

    ^ self text: s bounds: (pt extent: 10000@10000) font: fontOrNil color: c
! !

!Canvas methodsFor: 'drawing' stamp: 'jm 8/2/97 13:54'!
text: s bounds: boundsRect font: fontOrNil color: c
    "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used. Noop here; overridden by non-trivial canvases."
! !


!Canvas methodsFor: 'private'!
setOrigin: aPoint clipRect: aRectangle

    origin _ aPoint.
    clipRect _ aRectangle.
! !

!Canvas methodsFor: 'private'!
setShadowDrawing
    "Put this canvas into 'shadow drawing' mode, which is used to draw translucent shadows. While in this mode, all drawing operations are done in black through a gray mask. The mask allows some of the underlying pixels to show through, providing a crude sense of transparency."

    shadowDrawing _ true.! !
ParseNode subclass: #CascadeNode
    instanceVariableNames: 'receiver messages '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!
!CascadeNode commentStamp: 'di 5/22/1998 16:32' prior: 0!
CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'!


!CascadeNode methodsFor: 'initialize-release'!
receiver: receivingObject messages: msgs
    " Transcript show: 'abc'; cr; show: 'def' "

    receiver _ receivingObject.
    messages _ msgs! !


!CascadeNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

    receiver emitForValue: stack on: aStream.
    1 to: messages size - 1 do:
        [:i |
        aStream nextPut: Dup.
        stack push: 1.
        (messages at: i) emitForValue: stack on: aStream.
        aStream nextPut: Pop.
        stack pop: 1].
    messages last emitForValue: stack on: aStream! !

!CascadeNode methodsFor: 'code generation'!
sizeForValue: encoder

    | size |
    size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
    messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
    ^size! !


!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level
    self printOn: aStream indent: level precedence: 0! !

!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level precedence: p
    | thisPrec |
    p > 0 ifTrue: [aStream nextPut: $(].
    thisPrec _ messages first precedence.
    receiver printOn: aStream indent: level precedence: thisPrec.
    1 to: messages size do:
        [:i |
        (messages at: i) printOn: aStream indent: level.
        i < messages size
            ifTrue: [aStream nextPut: $;.
                    thisPrec >= 2 ifTrue: [aStream crtab: level]]].
    p > 0 ifTrue: [aStream nextPut: $)]! !


!CascadeNode methodsFor: 'C translation'!
asTranslatorNode
    ^TStmtListNode new
        setArguments: #()
        statements: (messages collect:
            [ :msg | msg asTranslatorNode receiver: receiver asTranslatorNode ])! !
Object subclass: #CautiousModel
    instanceVariableNames: 'initialExtent '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Support'!

!CautiousModel methodsFor: 'all' stamp: 'sw 8/15/97 17:20'!
fullScreenSize
    "Answer the size to which a window displaying the receiver should be set"

    ^ (0@0 extent: DisplayScreen actualScreenSize) copy! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'!
initialExtent
    initialExtent ifNotNil: [^ initialExtent].
    ^ super initialExtent! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 23:16'!
initialExtent: anExtent
    initialExtent _ anExtent! !

!CautiousModel methodsFor: 'all' stamp: 'sw 10/2/97 16:19'!
okToChange
    | parms |
    (parms _ Smalltalk at: #EToyParameters ifAbsent: [nil]) ifNotNil:
        [parms cautionBeforeClosing ifFalse: [^ true]].
    Sensor leftShiftDown ifTrue: [^ true].

    self beep.
    ^ self confirm: 'Warning!!
If you answer "yes" here, this
window will disappear and
its contents will be lost!!
Do you really want to do that?'

"CautiousModel new okToChange"! !
StringHolder subclass: #ChangeList
    instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Changes'!
!ChangeList commentStamp: 'di 5/22/1998 16:32' prior: 0!
A ChangeList represents a list of changed methods that reside on a file in fileOut format.  The classes and methods in my list are not necessarily in this image!!  Used as the model for both Version Lists and Changed Methods (in Screen Menu, Changes...).  Note that the two kinds of window have different controller classes!!!!

It holds three lists:
    changeList - a list of ChangeRecords
    list - a list of one-line printable headers
    listSelections - a list of Booleans (true = selected, false = not selected) multiple OK.
    listIndex
Items that are removed (removeDoits, remove an item) are removed from all three lists.
Most recently clicked item is the one showing in the bottom pane.!


!ChangeList methodsFor: 'initialization-release'!
addItem: item text: text
    | cr |
    cr _ Character cr.
    changeList addLast: item.
    list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! !


!ChangeList methodsFor: 'scanning' stamp: 'sw 1/15/98 21:56'!
scanCategory
    "Scan anything that involves more than one chunk; method name is historical only"

    | itemPosition item tokens stamp isComment anIndex |
    itemPosition _ file position.
    item _ file nextChunk.

    isComment _ (item includesSubString: 'commentStamp:').
    (isComment or: [item includesSubString: 'methodsFor:']) ifFalse:
        ["Maybe a preamble, but not one we recognize; bail out with the preamble trick"
        ^ self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble)
                 text: ('preamble: ' , item contractTo: 50)].

    tokens _ Scanner new scanTokens: item.
    tokens size >= 3 ifTrue:
        [stamp _ ''.
        anIndex _ tokens indexOf: #stamp: ifAbsent: [nil].
        anIndex ifNotNil: [stamp _ tokens at: (anIndex + 1)].

        tokens second == #methodsFor:
            ifTrue: [^ self scanCategory: tokens third class: tokens first
                            meta: false stamp: stamp].
        tokens third == #methodsFor:
            ifTrue: [^ self scanCategory: tokens fourth class: tokens first
                            meta: true stamp: stamp]].

        tokens second == #commentStamp:
            ifTrue:
                [stamp _ tokens third.
                self addItem:
                        (ChangeRecord new file: file position: file position type: #classComment
                                        class: tokens first category: nil meta: false stamp: stamp)
                        text: 'class comment for ' , tokens first,
                              (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp]).
                file nextChunk.
                ^ file skipStyleChunk]! !

!ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:56'!
scanCategory: category class: class meta: meta stamp: stamp
    | itemPosition method |
    [itemPosition _ file position.
    method _ file nextChunk.
    file skipStyleChunk.
    method size > 0]                        "done when double terminators"
        whileTrue:
        [self addItem: (ChangeRecord new file: file position: itemPosition type: #method
                            class: class category: category meta: meta stamp: stamp)
            text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' '])
                , (Parser new parseSelector: method)
                , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! !

!ChangeList methodsFor: 'scanning' stamp: 'di 1/13/98 16:57'!
scanFile: aFile from: startPosition to: stopPosition
    | itemPosition item prevChar |
    file _ aFile.
    changeList _ OrderedCollection new.
    list _ OrderedCollection new.
    listIndex _ 0.
    file position: startPosition.
'Scanning changes...'
    displayProgressAt: Sensor cursorPoint
    from: startPosition to: stopPosition
    during: [:bar |
    [file position < stopPosition]
        whileTrue:
        [bar value: file position.
        [file atEnd not and: [file peek isSeparator]]
                whileTrue: [prevChar _ file next].
        (file peekFor: $!!)
        ifTrue:
            [prevChar = Character cr ifTrue: [self scanCategory]]
        ifFalse:
            [itemPosition _ file position.
            item _ file nextChunk.
            file skipStyleChunk.
            item size > 0 ifTrue:
                [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt)
                    text: 'do it: ' , (item contractTo: 50)]]]].
    listSelections _ Array new: list size withAll: false! !

!ChangeList methodsFor: 'scanning' stamp: 'di 5/17/1998 12:01'!
scanVersionsOf: method class: class meta: meta category: category selector: selector
    | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp |
    changeList _ OrderedCollection new.
    list _ OrderedCollection new.
    listIndex _ 0.
    position _ method filePosition.
    sourceFilesCopy _ SourceFiles collect:
        [:x | x isNil ifTrue: [ nil ]
                ifFalse: [x readOnlyCopy]].
    method fileIndex == 0 ifTrue: [self inform: 'Not Logged, no versions'.
                                ^ nil].
    file _ sourceFilesCopy at: method fileIndex.
    [position notNil & file notNil]
        whileTrue:
        [file position: (0 max: position-150).  "Skip back to before the preamble"
        [file position < (position-1)]  "then pick it up from the front"
            whileTrue: [preamble _ file nextChunk].

        "Preamble is likely a linked method preamble, if we're in
            a changes file (not the sources file).  Try to parse it
            for prior source position and file index"
        prevPos _ nil.
        stamp _ ''.
        (preamble findString: 'methodsFor:' startingAt: 1) > 0
            ifTrue: [tokens _ Scanner new scanTokens: preamble]
            ifFalse: [tokens _ Array new  "ie cant be back ref"].
        ((tokens size between: 7 and: 8)
            and: [(tokens at: tokens size-5) = #methodsFor:])
            ifTrue:
                [(tokens at: tokens size-3) = #stamp:
                ifTrue: ["New format gives change stamp and unified prior pointer"
                        stamp _ tokens at: tokens size-2.
                        prevPos _ tokens last.
                        prevFileIndex _ prevPos // 16r1000000.
                        prevPos _ prevPos \\ 16r1000000]
                ifFalse: ["Old format gives no stamp; prior pointer in two parts"
                        prevPos _ tokens at: tokens size-2.
                        prevFileIndex _ tokens last].
                (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]].
        ((tokens size between: 5 and: 6)
            and: [(tokens at: tokens size-3) = #methodsFor:])
            ifTrue:
                [(tokens at: tokens size-1) = #stamp:
                ifTrue: ["New format gives change stamp and unified prior pointer"
                        stamp _ tokens at: tokens size]].
         self addItem:
                (ChangeRecord new file: file position: position type: #method
                        class: class name category: category meta: meta stamp: stamp)
            text: stamp , ' ' , class name , (meta ifTrue: [' class '] ifFalse: [' ']) , selector.
        position _ prevPos.
        prevPos notNil ifTrue:
            [file _ sourceFilesCopy at: prevFileIndex]].
    sourceFilesCopy do: [:x | x notNil ifTrue: [x close]].
    listSelections _ Array new: list size withAll: false! !

!ChangeList methodsFor: 'scanning' stamp: 'tk 4/24/1998 23:32'!
toggleListIndex: newListIndex

    (listIndex ~= 0 and: [listIndex ~= newListIndex]) ifTrue:
        [listSelections at: listIndex put: false].  "turn off old selection if was on"
    newListIndex = 0
        ifTrue: [listIndex _ 0]
        ifFalse: [
            listSelections at: newListIndex  "Complement selection state"
                    put: (listSelections at: newListIndex) not.
            listIndex _ (listSelections at: newListIndex)
                ifTrue: [newListIndex]  "and set selection index accordingly"
                ifFalse: [0]].
    self changed: #listIndex.
    self changed: #contents! !


!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/3/1998 19:15'!
acceptFrom: aView

    aView controller text = aView controller initialText ifFalse: [
        aView flash.
        ^ self inform: 'You can only accept this version as-is.
If you want to edit, copy the text to a browser'].
    (aView setText: aView controller text from: self) ifTrue:
        [aView ifNotNil: [aView controller accept]].    "initialText"
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/6/98 11:33'!
changeListMenu: aMenu

^ aMenu labels:
'fileIn selections
fileOut selections...
select conflicts
select conflicts with
select unchanged methods
select all
deselect all
remove doIts
remove older versions
remove selections'
    lines: #(2 6)
    selections: #(fileInSelections fileOutSelections selectConflicts selectConflictsWith selectUnchangedMethods selectAll deselectAll removeDoIts removeOlderMethodVersions removeSelections)
! !

!ChangeList methodsFor: 'menu actions'!
deselectAll
    listIndex _ 0.
    listSelections atAllPut: false.
    self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
fileInSelections
    listSelections with: changeList do:
        [:selected :item | selected ifTrue: [item fileIn]]! !

!ChangeList methodsFor: 'menu actions' stamp: 'jm 6/12/97 10:54'!
fileOutSelections
    | f |
    f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st').
    f header; timeStamp.
    listSelections with: changeList do:
        [:selected :item | selected ifTrue: [item fileOutOn: f]].
    f close.
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/21/1998 09:56'!
perform: selector orSendTo: otherTarget
    "Selector was just chosen from a menu by a user.  If I can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked."

    (#accept == selector) ifTrue: [^ self acceptFrom: otherTarget view].
    ^ super perform: selector orSendTo: otherTarget! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 4/8/98 12:38'!
removeDoIts
    "Remove doits from the receiver, other than initializes. 1/26/96 sw"

    | newChangeList newList |

    newChangeList _ OrderedCollection new.
    newList _ OrderedCollection new.

    changeList with: list do:
        [:chRec :str |
            (chRec type ~~ #doIt or:
                [str endsWith: 'initialize'])
                    ifTrue:
                        [newChangeList add: chRec.
                        newList add: str]].
    newChangeList size < changeList size
        ifTrue:
            [changeList _ newChangeList.
            list _ newList.
            listIndex _ 0.
            listSelections _ Array new: list size withAll: false].
    self changed: #list.

    ! !

!ChangeList methodsFor: 'menu actions' stamp: 'di 6/13/97 23:10'!
removeOlderMethodVersions
    "Remove older versions of entries from the receiver."
    | newChangeList newList found str |
    newChangeList _ OrderedCollection new.
    newList _ OrderedCollection new.
    found _ OrderedCollection new.

    changeList reverseWith: list do:
        [:chRec :strNstamp | str _ strNstamp copyUpTo: $;.
            (found includes: str)
                ifFalse:
                    [found add: str.
                    newChangeList add: chRec.
                    newList add: strNstamp]].
    newChangeList size < changeList size
        ifTrue:
            [changeList _ newChangeList reversed.
            list _ newList reversed.
            listIndex _ 0.
            listSelections _ Array new: list size withAll: false].
    self changed: #list! !

!ChangeList methodsFor: 'menu actions'!
removeSelections
    "Remove the selected items from the receiver.  9/18/96 sw"

    | newChangeList newList |

    newChangeList _ OrderedCollection new.
    newList _ OrderedCollection new.

    1 to: changeList size do:
        [:i | (listSelections at: i) ifFalse:
            [newChangeList add: (changeList at: i).
            newList add: (list at: i)]].
    newChangeList size < changeList size
        ifTrue:
            [changeList _ newChangeList.
            list _ newList.
            listIndex _ 0.
            listSelections _ Array new: list size withAll: false].
    self changed: #list

    ! !

!ChangeList methodsFor: 'menu actions'!
selectAll
    listIndex _ 0.
    listSelections atAllPut: true.
    self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts
    "Selects all method definitions for which there is ALSO an entry in changes"
    | change class systemChanges |
    Cursor read showWhile:
    [1 to: changeList size do:
        [:i | change _ changeList at: i.
        listSelections at: i put:
            (change type = #method
            and: [(class _ change methodClass) notNil
            and: [(Smalltalk changes atSelector: change methodSelector
                        class: class) ~~ #none]])]].
    self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions'!
selectConflicts: changeSetOrList
    "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
    | change class systemChanges |
    Cursor read showWhile:
    [(changeSetOrList isKindOf: ChangeSet) ifTrue: [
    1 to: changeList size do:
        [:i | change _ changeList at: i.
        listSelections at: i put:
            (change type = #method
            and: [(class _ change methodClass) notNil
            and: [(changeSetOrList atSelector: change methodSelector
                        class: class) ~~ #none]])]]
    ifFalse: ["a ChangeList"
    1 to: changeList size do:
        [:i | change _ changeList at: i.
        listSelections at: i put:
            (change type = #method
            and: [(class _ change methodClass) notNil
            and: [changeSetOrList list includes: (list at: i)]])]]
    ].
    self changed: #allSelections! !

!ChangeList methodsFor: 'menu actions' stamp: 'jm 5/22/1998 11:31'!
selectConflictsWith
    "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk"
    | aStream all index |
    aStream _ WriteStream on: (String new: 200).
    all _ ChangeSet allInstances asOrderedCollection.
    all do:
        [:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
    ChangeList allInstancesDo:
        [:sel | aStream nextPutAll: (sel file name); cr.
            all addLast: sel].
    aStream skip: -1.
    index _ (PopUpMenu labels: aStream contents) startUp.
    index > 0 ifTrue: [
        self selectConflicts: (all at: index)].
! !

!ChangeList methodsFor: 'menu actions' stamp: 'tk 1/7/98 10:12'!
selectUnchangedMethods
    "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same.  9/18/96 sw"
    | change class |
    Cursor read showWhile:
    [1 to: changeList size do:
        [:i | change _ changeList at: i.
        listSelections at: i put:
            ((change type = #method and:
                [(class _ change methodClass) notNil]) and:
                    [(class includesSelector: change methodSelector) and:
                        [change string = (class sourceCodeAt: change methodSelector) asString]])]].
    self changed: #allSelections! !


!ChangeList methodsFor: 'viewing access' stamp: 'sw 1/15/98 22:45'!
contents
    ^ listIndex = 0
        ifTrue: ['']
        ifFalse: [(changeList at: listIndex) text]! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/10/1998 09:25'!
contents: aString
    listIndex = 0 ifTrue: [self changed: #flash. ^ false].
    lostMethodPointer ifNotNil: [^ self restoreDeletedMethod].
    self okToChange "means not dirty" ifFalse: ["is dirty"
        self inform: 'This is a view of a method on a file.\Please cancel your changes.  You may\accept, but only when the method is untouched.' withCRs.  ^ false].
        "Can't accept changes here.  Method text must be unchanged!!"
    (changeList at: listIndex) fileIn.
    ^ true! !

!ChangeList methodsFor: 'viewing access'!
defaultBackgroundColor
    ^ #lightBlue! !

!ChangeList methodsFor: 'viewing access'!
list
    ^ list! !

!ChangeList methodsFor: 'viewing access'!
listIndex
    ^ listIndex! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index
    ^ listSelections at: index! !

!ChangeList methodsFor: 'viewing access'!
listSelectionAt: index put: value
    listIndex _ 0.
    ^ listSelections at: index put: value! !

!ChangeList methodsFor: 'viewing access' stamp: 'di 6/15/97 16:46'!
restoreDeletedMethod
    "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed.  In this case we want to establish a sourceCode link to prior versions.  We do this by installing a dummy method with the correct source code pointer prior to installing this version."
    | dummyMethod class selector |
    dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer.
    class _ (changeList at: listIndex) methodClass.
    selector _ (changeList at: listIndex) methodSelector.
    class addSelector: selector withMethod: dummyMethod.
    (changeList at: listIndex) fileIn.
    "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails."
    (class compiledMethodAt: selector) == dummyMethod
        ifTrue: [class removeSelectorSimply: selector].
    ^ true! !

!ChangeList methodsFor: 'viewing access' stamp: 'tk 4/18/1998 09:46'!
selectedMessageName

    ^ (changeList at: listIndex) methodSelector

"
change _ changeList at: i.
            ((change type = #method and:
                [(class _ change methodClass) notNil]) and:
                    [(class includesSelector: change methodSelector
"! !


!ChangeList methodsFor: 'accessing'!
changeList
    ^ changeList! !

!ChangeList methodsFor: 'accessing'!
file
    ^file! !

!ChangeList methodsFor: 'accessing' stamp: 'di 6/15/97 15:13'!
setLostMethodPointer: sourcePointer
    lostMethodPointer _ sourcePointer! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeList class
    instanceVariableNames: ''!

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'!
browseFile: fileName    "ChangeList browseFile: 'AutoDeclareFix.st'"
    "Opens a changeList on the file named fileName"
    | changesFile changeList |
    changesFile _ FileStream readOnlyFileNamed: fileName.
    Cursor read showWhile:
        [changeList _ self new
            scanFile: changesFile from: 0 to: changesFile size].
    changesFile close.
    self open: changeList name: fileName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:53'!
browseRecent: charCount    "ChangeList browseRecent: 5000"
    "Opens a changeList on the end of the changes log file"
    | changesFile changeList end |
    changesFile _ (SourceFiles at: 2) readOnlyCopy.
    end _ changesFile size.
    Cursor read showWhile:
        [changeList _ self new
            scanFile: changesFile from: (0 max: end-charCount) to: end].
    changesFile close.
    self open: changeList name: 'Recent changes' multiSelect: true! !

!ChangeList class methodsFor: 'public access'!
browseRecentLog    "ChangeList browseRecentLog"
    "Prompt with a menu of how far back to go"
    | end changesFile banners positions pos chunk i |
    changesFile _ (SourceFiles at: 2) readOnlyCopy.
    banners _ OrderedCollection new.
    positions _ OrderedCollection new.
    end _ changesFile size.
    pos _ Smalltalk lastQuitLogPosition.
    [pos = 0 or: [banners size > 20]] whileFalse:
        [changesFile position: pos.
        chunk _ changesFile nextChunk.
        i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1.
        i > 0 ifTrue: [positions addLast: pos.
                    banners addLast: (chunk copyFrom: 5 to: i-2).
                    pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)]
            ifFalse: [pos _ 0]].
    changesFile close.
    pos _ (SelectionMenu labelList: banners reversed selections: positions reversed)
                startUpWithCaption: 'Browse as far back as...'.
    pos == nil ifTrue: [^ self].
    self browseRecent: end-pos! !

!ChangeList class methodsFor: 'public access' stamp: 'tk 5/19/1998 14:24'!
browseStream: changesFile
    "Opens a changeList on a fileStream"
    | changeList |

    changesFile readOnly.
    Cursor read showWhile:
        [changeList _ self new
            scanFile: changesFile from: 0 to: changesFile size].
    changesFile close.
    self open: changeList name: changesFile localName , ' log' multiSelect: true! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'!
browseVersionsOf: method class: class meta: meta
        category: category selector: selector
    | changeList |
    Cursor read showWhile:
        [changeList _ self new
            scanVersionsOf: method class: class meta: meta
            category: category selector: selector].
    changeList ifNotNil:
        [self open: changeList name: 'Recent versions of ' , selector multiSelect: false]! !

!ChangeList class methodsFor: 'public access' stamp: 'di 5/16/1998 21:56'!
browseVersionsOf: method class: class meta: meta
        category: category selector: selector lostMethodPointer: sourcePointer
    | changeList |
    Cursor read showWhile:
        [changeList _ self new
            scanVersionsOf: method class: class meta: meta
            category: category selector: selector].
    changeList setLostMethodPointer: sourcePointer.
    self open: changeList name: 'Recent versions of ' , selector multiSelect: false! !

!ChangeList class methodsFor: 'public access'!
versionCountForSelector: aSelector class: aClass
    "Answer the number of versions known to the system for the given class and method, including the current version.  A result of greater than one means that there is at least one superseded version.  6/28/96 sw"

    | method |
    method _ aClass compiledMethodAt: aSelector.
    ^ (self new
            scanVersionsOf: method class: aClass meta: aClass isMeta
            category: nil selector: aSelector) list size! !


!ChangeList class methodsFor: 'instance creation' stamp: 'di 5/17/1998 22:49'!
open: aChangeList name: aString multiSelect: multiSelect
    "Create a standard system view for the messageSet, whose label is aString.
    The listView may be either single or multiple selection type"
    | topView aBrowserCodeView aListView |

    World ifNotNil: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect].

    topView _ (StandardSystemView new) model: aChangeList.
    topView label: aString.
    topView minimumSize: 180 @ 120.
    topView borderWidth: 1.

    aListView _ (multiSelect ifTrue: [PluggableListViewOfMany]
                            ifFalse: [PluggableListView])
        on: aChangeList list: #list
        selected: #listIndex changeSelected: #toggleListIndex:
        menu: #changeListMenu:
        keystroke: #messageListKey:from:.
    aListView window: (0 @ 0 extent: 180 @ 100).
    topView addSubView: aListView.

    aBrowserCodeView _ PluggableTextView on: aChangeList
            text: #contents accept: #contents:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    aBrowserCodeView controller: ReadOnlyTextController new.
    aBrowserCodeView window: (0 @ 0 extent: 180 @ 300).
    topView addSubView: aBrowserCodeView below: aListView.
    topView controller open! !

!ChangeList class methodsFor: 'instance creation' stamp: 'di 5/16/1998 22:15'!
openAsMorph: aChangeList name: labelString multiSelect: multiSelect
    "Open a morphic view for the messageSet, whose label is labelString.
    The listView may be either single or multiple selection type"
    | window listView textMorph |
    window _ (SystemWindow labelled: labelString) model: aChangeList.

    window addMorph: (listView _ PluggableListMorph on: aChangeList list: #list
        selected: #listIndex changeSelected: #toggleListIndex:
        menu: #changeListMenu: keystroke: #messageListKey:from:)
        frame: (0@0 corner: 1@0.3).
"
    multiSelect ifTrue: [listView controller: PluggableListControllerOfMany new].
"
    window addMorph: (textMorph _ PluggableTextMorph on: aChangeList
            text: #contents accept: #contents:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
        frame: (0@0.3 corner: 1@1).
"
    textMorph controller: ReadOnlyTextController new.
"
    ^ window openInWorld! !
Object subclass: #ChangeRecord
    instanceVariableNames: 'file position type class category meta stamp '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Changes'!
!ChangeRecord commentStamp: 'di 5/22/1998 16:32' prior: 0!
ChangeRecord comment:
'A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.'!


!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:46'!
fileIn
    | methodClass |
    Cursor read showWhile:
        [(methodClass _ self methodClass) notNil ifTrue:
            [methodClass compile: self text classified: category withStamp: stamp notifying: nil].
        (type == #doIt) ifTrue:
            [Compiler evaluate: self string].
        (type == #classComment) ifTrue:
            [(Smalltalk at: class asSymbol) comment: self text]]! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:09'!
fileOutOn: f
    type == #method
        ifTrue:
            [f nextPut: $!!.
            f nextChunkPut: class asString
                    , (meta ifTrue: [' class methodsFor: ']
                            ifFalse: [' methodsFor: '])
                    , category asString printString.
            f cr].

    type == #preamble ifTrue: [f nextPut: $!!].

    type == #classComment
        ifTrue:
            [f nextPut: $!!.
            f nextChunkPut: class asString, ' commentStamp: ', stamp storeString.
            f cr].

    f nextChunkPut: self string.
    type == #method ifTrue: [f nextChunkPut: ' '].
    f cr! !

!ChangeRecord methodsFor: 'access'!
methodClass
    | methodClass |
    type == #method ifFalse: [^ nil].
    (Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
    methodClass _ Smalltalk at: class asSymbol.
    meta ifTrue: [^ methodClass class]
        ifFalse: [^ methodClass]! !

!ChangeRecord methodsFor: 'access'!
methodSelector
    type == #method ifFalse: [^ nil].
    ^ Parser new parseSelector: self string! !

!ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'!
stamp
    ^ stamp! !

!ChangeRecord methodsFor: 'access' stamp: 'di 1/13/98 16:57'!
string
    | string |
    file openReadOnly.
    file position: position.
    string _ file nextChunk.
    file close.
    ^ string! !

!ChangeRecord methodsFor: 'access' stamp: 'sw 1/15/98 22:35'!
text
    | text |
    file openReadOnly.
    file position: position.
    text _ file nextChunkText.
    file close.
    ^ text! !

!ChangeRecord methodsFor: 'access'!
type
    ^ type! !


!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
    file _ f.
    position _ p.
    type _ t! !

!ChangeRecord methodsFor: 'initialization' stamp: '6/6/97 08:48 dhhi'!
file: f position: p type: t class: c category: cat meta: m stamp: s
    self file: f position: p type: t.
    class _ c.
    category _ cat.
    meta _ m.
    stamp _ s! !
Object subclass: #ChangeSet
    instanceVariableNames: 'classChanges methodChanges classRemoves methodRemoves name preamble postscript '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Changes'!
!ChangeSet commentStamp: 'di 5/22/1998 16:32' prior: 0!
ChangeSet comment:
'My instances keep track of the changes made to a system, so the user can make an incremental fileOut. The order in which changes are made is not remembered.

classChanges:  Dictionary {class name -> Set {eg, #change, #rename, etc}}.
methodChanges:  Dictionary {class name -> IdentityDictionary {selector -> {eg, #change, #remove, etc}}.
classRemoves:  Set {class name (original)}.
methodRemoves:  Dictionary {(Array with: class name with: selector) -> (Array with: source pointer with: category)}.
name: a String used to name the changeSet, and thus any associated project or fileOut.
preamble and postscript:  two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet.'!


!ChangeSet methodsFor: 'initialize-release' stamp: 'sw 11/26/96'!
clear
    "Reset the receiver to be empty.  "

    classChanges _ Dictionary new.
    methodChanges _ Dictionary new.
    classRemoves _ Set new.
    preamble _ nil.
    postscript _ nil! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'tk 5/4/1998 16:41'!
editPostscript
    "edit the receiver's postscript, in a separate window.  "

    self assurePostscriptExists.
    postscript openLabel: 'Postscript for ChangeSet named ', name! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'!
initialize
    "Reset the receiver to be empty."

    self wither.  "Avoid duplicate entries in AllChangeSets if initialize gets called twice"
    name _ ChangeSet defaultName! !

!ChangeSet methodsFor: 'initialize-release'!
isMoribund
    "Answer whether the receiver is obsolete and about to die; part of an effort to get such guys cleared out from the change sorter.  2/7/96 sw"

    ^ name == nil ! !

!ChangeSet methodsFor: 'initialize-release' stamp: 'di 5/21/1998 20:50'!
wither
    "The receiver is to be clobbered.  Clear it out.  2/7/96 sw"

    classChanges _ Dictionary new.
    methodChanges _ Dictionary new.
    classRemoves _ Set new.
    methodRemoves _ Dictionary new.
    name _ nil! !


!ChangeSet methodsFor: 'testing' stamp: 'jm 5/22/1998 11:33'!
belongsToAProject

    Project allInstancesDo: [:proj |
        proj projectChangeSet == self ifTrue: [^ true]].
    ^ false
! !

!ChangeSet methodsFor: 'testing' stamp: 'tk 5/7/1998 12:57'!
classChangeAt: className
    "Return what we know about class changes to this class."
    | this |

    this _ classChanges at: className ifAbsent: [Set new].
    (classRemoves includes: className) ifTrue: [this add: #remove].
    ^ this! !

!ChangeSet methodsFor: 'testing'!
classRemoves
    ^ classRemoves! !

!ChangeSet methodsFor: 'testing'!
isEmpty
    "Answer whether the receiver contains any elements."

    ^(methodChanges isEmpty and: [classChanges isEmpty]) and: [classRemoves isEmpty]! !

!ChangeSet methodsFor: 'testing'!
methodChangesAtClass: className
    "Return what we know about method changes to this class."
    ^ methodChanges at: className ifAbsent: [Dictionary new].! !

!ChangeSet methodsFor: 'testing'!
name
    "The name of this changeSet.
     2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

    ^ name == nil
        ifTrue:
            ['<no name -- garbage?>']
        ifFalse:
            [name]! !

!ChangeSet methodsFor: 'testing' stamp: 'sw 10/1/97 17:59'!
okayToRemove
    | aName |
    aName _ self name.
    self == Smalltalk changes ifTrue:
        [self inform: 'Cannot remove "', aName, '"
because it is the
current change set.'.
        ^ false].

    self belongsToAProject ifTrue:
        [self inform: 'Cannot remove "', aName, '"
because it belongs to a
project.'.
            ^ false].

    ^ true
! !


!ChangeSet methodsFor: 'converting'!
asSortedCollection
    "Answer a SortedCollection whose elements are the elements of the
    receiver. The sort order is the default less than or equal ordering."
    | result |
    result _ SortedCollection new.
    classChanges associationsDo:
        [:clAssoc |
        clAssoc value do:
            [:changeType | result add: clAssoc key, ' - ', changeType]].
    methodChanges associationsDo:
        [:clAssoc |
        clAssoc value associationsDo:
            [:mAssoc | result add: clAssoc key, ' ', mAssoc key, ' - ', mAssoc value]].
    classRemoves do:
        [:cName | result add: cName  , ' - ', 'remove'].
    ^ result! !


!ChangeSet methodsFor: 'change management' stamp: 'di 5/6/1998 16:39'!
absorbChangesInChangeSetsNamed: nameList
    "Absorb into the receiver all the changes found in change sets of the given names.  *** classes renamed in aChangeSet may have have problems"

    | aChangeSet |
    nameList do:
        [:aName | (aChangeSet _ ChangeSorter changeSetNamed: aName) ~~ nil
            ifTrue:
                [self assimilateAllChangesFoundIn: aChangeSet]]! !

!ChangeSet methodsFor: 'change management'!
addClass: class
    "Include indication that a new class was created."

    self atClass: class add: #add! !

!ChangeSet methodsFor: 'change management' stamp: 'tk 5/7/1998 13:24'!
assimilateAllChangesFoundIn: aChangeSet
    "Make all changes in aChangeSet take effect on self as if they happened just now.  *** classes renamed in aChangeSet may have have problems"

    | cls info selector pair |
    aChangeSet changedClassNames do: [:className |
      (cls _ Smalltalk classNamed: className) ifNotNil:
        [info _ aChangeSet classChangeAt: className.
        info do: [:each | self atClass: cls add: each].

        info _ aChangeSet methodChanges at: className
            ifAbsent: [Dictionary new].
        info associationsDo: [:assoc |
            assoc value == #remove
                ifTrue:
                    [selector _ assoc key.
                    self removeSelector: selector class: cls.
                    pair _ aChangeSet methodRemoves
                            at: (Array with: cls name with: selector)
                            ifAbsent: [nil].
                    pair ifNotNil:
                        ["Retain source code ref if stored"
                        methodRemoves at: (Array with: cls name with: selector)
                                        put: pair]]
                ifFalse:
                    [self atSelector: assoc key class: cls put: assoc value]]]].
        classRemoves addAll: aChangeSet classRemoves.    "names of them"
! !

!ChangeSet methodsFor: 'change management'!
changeClass: class
    "Include indication that a class definition has been changed.
     6/10/96 sw: don't accumulate this information for classes that don't want logging
     7/12/96 sw: use wantsChangeSetLogging flag"

    class wantsChangeSetLogging
        ifTrue:
            [self atClass: class add: #change]! !

!ChangeSet methodsFor: 'change management'!
changedClasses
    "Answer a OrderedCollection of changed or edited classes.  Not including removed classes.  Sort alphabetically by name."

    "Much faster to sort names first, then convert back to classes.  Because metaclasses reconstruct their name at every comparison in the sorted collection.
    8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames"
    classChanges == nil ifTrue: [^ OrderedCollection new].
    ^ self changedClassNames collect:
        [:className | Smalltalk classNamed: className]
            thenSelect:
                [:aClass | aClass notNil]! !

!ChangeSet methodsFor: 'change management' stamp: 'tk 5/7/1998 12:55'!
changedClassNames
    "Answer a OrderedCollection of the names of changed or edited classes.  DOES include removed classes.  Sort alphabetically."

    | classes |
    classes _ SortedCollection new: (methodChanges size + classChanges size) *2.
    methodChanges keys do: [:className | classes add: className].
    classChanges keys do: [:className |
        (methodChanges includesKey: className) ifFalse: [
            "avoid duplicates, faster than (classes addIfNotPresent: xx)"
            classes add: className]].
    classRemoves do: [:className | classes addIfNotPresent: className].
    ^ classes asOrderedCollection! !

!ChangeSet methodsFor: 'change management'!
commentClass: class
    "Include indication that a class comment has been changed."

    self atClass: class add: #comment! !

!ChangeSet methodsFor: 'change management'!
flushClassRemoves
    classRemoves _ Set new! !

!ChangeSet methodsFor: 'change management' stamp: 'sw 5/21/1998 18:30'!
forgetAllChangesFoundIn: aChangeSet
    "Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets.  To use:  in a change sorter, copy over all the changes you want into some new change set, then use the subtract-other-side feature to subtract those changes from the larger change set, and continue in this manner.  (But, remember that if a changeSet says #add, but the method is missing in the image, it won't file out!!)"
    | cls itsMethodChanges |
    aChangeSet == self ifTrue: [^ self].

    aChangeSet changedClassNames do:
        [:className | (cls _ Smalltalk classNamed: className) ~~ nil ifTrue:
                [itsMethodChanges _ aChangeSet methodChanges at: className
                        ifAbsent: [Dictionary new].
                itsMethodChanges associationsDo:
                    [:assoc | self undoChange: assoc value for: assoc key class: cls].
                        "try to undo the change found in aChangeSet"
                (aChangeSet hasClassChangesFor: className) ifTrue:
                    [self removeClassChanges: cls]]].
    classRemoves removeAllFoundIn: aChangeSet classRemoves.    "names of them"
! !

!ChangeSet methodsFor: 'change management' stamp: 'sw 2/3/98 14:21'!
hasClassChangesFor: aKey
    ^ classChanges includesKey: aKey! !

!ChangeSet methodsFor: 'change management' stamp: 'sw 9/17/97 20:47'!
noteRemovalOf: aClass
    "The class is about to be removed from the system.  Adjust the receiver to reflect that fact."

    classChanges removeKey: aClass name ifAbsent: [].
    methodChanges removeKey: aClass name ifAbsent: [].
    classChanges removeKey: aClass class name ifAbsent: [].
    methodChanges removeKey: aClass class name ifAbsent: [].
    classRemoves add: aClass name! !

!ChangeSet methodsFor: 'change management'!
removeClassAndMetaClassChanges: class
    "Remove all memory of changes associated with this class and its metaclass.  7/18/96 sw"

    classChanges removeKey: class name ifAbsent: [].
    methodChanges removeKey: class name ifAbsent: [].
    classChanges removeKey: class class name ifAbsent: [].
    methodChanges removeKey: class class name ifAbsent: [].
    classRemoves remove: class name ifAbsent: [].! !

!ChangeSet methodsFor: 'change management'!
removeClassChanges: class
    "Remove all memory of changes associated with this class"

    classChanges removeKey: class name ifAbsent: [].
    methodChanges removeKey: class name ifAbsent: [].
    classRemoves remove: class name ifAbsent: [].! !

!ChangeSet methodsFor: 'change management'!
renameClass: class as: newName
    "Include indication that a class has been renamed."

    | value |
    (self atClass: class includes: #rename) ifFalse:
        [self atClass: class add: 'oldName: ', class name.     "only original name matters"
        self atClass: class add: #rename].
     "copy changes using new name (metaclass too)"
    (Array with: classChanges with: methodChanges) do:
        [:changes |
        (value _ changes at: class name ifAbsent: [nil]) == nil ifFalse:
            [changes at: newName put: value.
            changes removeKey: class name].
        (value _ changes at: class class name ifAbsent: [nil]) == nil ifFalse:
            [changes at: (newName, ' class') put: value.
            changes removeKey: class class name]]! !

!ChangeSet methodsFor: 'change management'!
reorganizeClass: class
    "Include indication that a class was reorganized."

    self atClass: class add: #reorganize! !


!ChangeSet methodsFor: 'method changes'!
addSelector: selector class: class
    "Include indication that a method has been added.
     5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions."

    Utilities noteMethodSubmission: selector forClass: class name.
    self atSelector: selector class: class put: #add! !

!ChangeSet methodsFor: 'method changes'!
allMessagesForAddedClasses
    | messageList  mAssoc |
    "Smalltalk changes allMessagesForAddedClasses"
    messageList _ SortedCollection new.
    classChanges associationsDo:
        [:clAssoc |
        (clAssoc value includes: #add)
            ifTrue:
                [(Smalltalk at: clAssoc key) selectorsDo:
                    [:aSelector |
                        messageList add: clAssoc key asString, ' ' , aSelector].
                (Smalltalk at: clAssoc key) class selectorsDo:
                    [:aSelector |
                        messageList add: clAssoc key asString, ' class ' , aSelector]]].
    ^ messageList asArray! !

!ChangeSet methodsFor: 'method changes'!
browseMessagesWithPriorVersions
    "Open a message list browser on the new and changed methods in the receiver which have at least one prior version.  6/28/96 sw"

    | aList aSelector aClass |

    aList _ self changedMessageListAugmented select:
        [:msg |  Utilities setClassAndSelectorFrom: msg in:
                [:cl :sl | aClass _ cl.  aSelector _ sl].
            (ChangeList versionCountForSelector: aSelector class: aClass) > 1].
    aList size > 0 ifFalse: [self inform: 'None!!'.  ^ nil].
    Smalltalk browseMessageList: aList name: (self name, ' methods that have prior versions')! !

!ChangeSet methodsFor: 'method changes'!
changedMessageList
    "Used by a message set browser to access the list view information."

    | messageList |
    messageList _ SortedCollection new.
    methodChanges associationsDo:
        [:clAssoc |
        clAssoc value associationsDo:
            [:mAssoc |
            mAssoc value = #remove ifFalse:
                [messageList add: clAssoc key asString, ' ' , mAssoc key]]].
    ^messageList asArray! !

!ChangeSet methodsFor: 'method changes'!
changedMessageListAugmented
    "In addition to changedMessageList, put all messages for all added classes in the ChangeSet."
    ^ self changedMessageList asArray, self allMessagesForAddedClasses! !

!ChangeSet methodsFor: 'method changes'!
changeSelector: selector class: class
    "Include indication that a method has been edited.
     5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions."

    Utilities noteMethodSubmission: selector forClass: class name.
    (self atSelector: selector class: class) = #add
        ifFalse: [self atSelector: selector class: class put: #change]
            "Don't forget a method is new just because it's been changed"! !

!ChangeSet methodsFor: 'method changes' stamp: 'di 9/22/97 13:18'!
removeSelector: selector class: class
    "Include indication that a method has been forgotten."

    (self atSelector: selector class: class) = #add
        ifTrue: [self atSelector: selector
                    class: class
                    put: #addedThenRemoved]
        ifFalse: [self atSelector: selector
                    class: class
                    put: #remove].

    (class includesSelector: selector) ifTrue:
        ["Save the source code pointer and category so can still browse old versions"
        methodRemoves at: (Array with: class name with: selector)
            put: (Array with: (class compiledMethodAt: selector) sourcePointer
                        with: (class whichCategoryIncludesSelector: selector))]! !

!ChangeSet methodsFor: 'method changes'!
removeSelectorChanges: selector class: class
    "Remove all memory of changes associated with the argument, selector, in
    this class."

    | dictionary |
    dictionary _ methodChanges at: class name ifAbsent: [^self].
    dictionary removeKey: selector ifAbsent: [].
    dictionary isEmpty ifTrue: [methodChanges removeKey: class name]! !

!ChangeSet methodsFor: 'method changes' stamp: 'sw 10/31/97 23:59'!
selectorList
    "answer a set of all the selectors represented in the change set"
    "Smalltalk changes selectorList"
    | aList |
    aList _ OrderedCollection new.
    methodChanges associationsDo:
        [:clAssoc |
        clAssoc value associationsDo:
            [:mAssoc |
            (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
                [aList add: mAssoc key]]].
    ^ aList asSet! !

!ChangeSet methodsFor: 'method changes'!
selectorsInClass: aClass
    "Used by a ChangeSorter to access the list methods."
    "later include class changes"
    ^ (methodChanges at: aClass ifAbsent: [^#()]) keys! !

!ChangeSet methodsFor: 'method changes' stamp: 'tk 5/7/1998 15:26'!
undoChange: action for: selector class: class
    "Try to undo the change.  Remember that if a changeSet says #add, but the method is missing in the image, it won't file out!!

Current cng:     Add  Remove  Add+Remove
undo: Add       none  Remove  Remove
undo: Remove  Add    none     Add
undo:Add+Rem  none  none     none
(none means the method is entirely deleted from the changeSet)"

    | dictionary prev |
    dictionary _ methodChanges at: class name ifAbsent: [^self].
    prev _ dictionary at: selector ifAbsent: [^self].
    action == #addedThenRemoved ifTrue: [
        dictionary removeKey: selector ifAbsent: [].
        dictionary isEmpty ifTrue: [methodChanges removeKey: class name].
        ^ self].
    action == prev ifTrue: [dictionary removeKey: selector ifAbsent: [].
        dictionary isEmpty ifTrue: [methodChanges removeKey: class name].
        ^ self].
    action == #add ifTrue: [dictionary at: selector put: #remove].
    action == #remove ifTrue: [dictionary at: selector put: #add].
    dictionary isEmpty ifTrue: [methodChanges removeKey: class name]!
]style[(45 129 40 812)f1b,f1,f1u,f1! !


!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
assurePostscriptExists
    "Make sure there is a StringHolder holding the postscript.  "

    postscript == nil ifTrue: [postscript _ StringHolder new contents: '']! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
assurePreambleExists
    "Make sure there is a StringHolder holding the preamble.
     : if it's found to have reverted to empty contents, put up the template"

    (preamble == nil or: [preamble contents size == 0])
        ifTrue: [preamble _ StringHolder new contents: self preambleTemplate]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 5/7/1998 14:23'!
checkForSlips
    "Return a collection of method refs with possible debugging code in them."
    | slips tsRef changes method |
    slips _ OrderedCollection new.
    tsRef _ Smalltalk associationAt: #Transcript.
    self changedClasses do:
        [:aClass |
        changes _ methodChanges at: aClass name ifAbsent: [nil].
        changes ifNotNil:
            [changes associationsDo:
                [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse:
                    [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil].
                    method ifNotNil:
                        [((method hasLiteral: #halt) or: [method hasLiteral: tsRef])
                            ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]].
    ^ slips! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 08:26'!
fileOut
    "File out the receiver, to a file whose name is a function of the change-set name and of the date and the time."
    | file slips |
    Cursor write showWhile: [
        file _ FileStream newFileNamed:
            ((self name, FileDirectory dot, Utilities dateTimeSuffix, FileDirectory dot, 'cs')
                truncateTo: 27).
        file header; timeStamp.
        self fileOutPreambleOn: file.
        self fileOutOn: file.
        self fileOutPostscriptOn: file.
        file trailer; close].

    Preferences suppressCheckForSlips ifTrue: [^ self].  "Can hard-code that pref if desired"

    slips _ self checkForSlips.
    (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts
or references to the Transcript in them.
Would you like to browse them?'])
        ifTrue: [Smalltalk browseMessageList: slips
                            name: 'References to #halt or Transcript']! !

!ChangeSet methodsFor: 'fileIn/Out'!
fileOutChangesFor: class on: stream
    "Write out all the changes the receiver knows about this class.
     5/15/96 sw: altered to call fileOutClassModifications:on: rather than fileOutClassChanges:on:, so that class headers won't go out as part of this process (they no go out at the beginning of the fileout"

    | changes |
                    "first file out class changes"
    self fileOutClassModifications: class on: stream.
                    "next file out changed methods"
    changes _ OrderedCollection new.
    (methodChanges at: class name ifAbsent: [^ self]) associationsDo:
        [:mAssoc |
        mAssoc value = #remove
            ifFalse: [changes add: mAssoc key]].
    changes isEmpty ifFalse:
        [class fileOutChangedMessages: changes on: stream.
        stream cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 9/17/97 21:01'!
fileOutOn: stream
    "Write out all the changes the receiver knows about"

    | classList |
    self isEmpty ifTrue: [self notify: 'Warning: no changes to file out'].
    classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection.
    classList do:
        [:aClass |  "if class defn changed, put it onto the file now"
            self fileOutClassDefinition: aClass on: stream].
    classList do:
        [:aClass |  "nb: he following no longer puts out class headers"
            self fileOutChangesFor: aClass on: stream].
    stream cr.
    classList do:
        [:aClass |
        self fileOutPSFor: aClass on: stream].
    classRemoves do:
        [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:14'!
fileOutPostscriptOn: stream
    "If the receiver has a postscript, put it out onto the stream.  "

    | aString |
    ((aString _ self postscriptString) size > 0)
        ifTrue:
            [stream nextChunkPut: aString "surroundedBySingleQuotes".
            stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:15'!
fileOutPreambleOn: stream
    "If the receiver has a preamble, put it out onto the stream.  "

    | aString |
    ((aString _ self preambleString) size > 0)
        ifTrue:
            [stream nextChunkPut: aString "surroundedBySingleQuotes".
            stream cr; cr]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/20/1998 02:59'!
fileOutPSFor: class on: stream
    "Write out removals and initialization for this class."

    (methodChanges at: class name ifAbsent: [^ self]) associationsDo: [:mAssoc |
        (#(remove addedThenRemoved) includes: mAssoc value)
            ifTrue:
                [stream nextChunkPut: class name,
                    ' removeSelector: ', mAssoc key storeString; cr]
            ifFalse:
                [(mAssoc key = #initialize and: [class isMeta]) ifTrue:
                    [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:16'!
postscriptString
    "Answer the string representing the postscript.  "

    ^ postscript == nil
        ifTrue:
            [postscript]
        ifFalse:
            [postscript contents asString]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
postscriptString: aString
    "Establish aString as the new contents of the postscript.  "

    postscript _ StringHolder new contents: aString! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/7/1998 12:08'!
preambleString
    "Answer the string representing the preamble"

    ^ preamble == nil
        ifTrue:
            [preamble]
        ifFalse:
            [preamble contents asString]! !

!ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 11/27/96'!
preambleString: aString
    "Establish aString as the new contents of the preamble.  "

    preamble _ StringHolder new contents: aString! !

!ChangeSet methodsFor: 'fileIn/Out'!
preambleTemplate
    "Answer a string that will form the default contents for a change set's preamble.  Just a first stab at what the content should be.12/3/96 sw"

    | aStream |
    aStream _ ReadWriteStream on: ''.
    aStream nextPutAll: '"Change Set:'.
    aStream tab;tab; nextPutAll: self name.
    aStream cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString.
    aStream cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: 'Your Name'.
    aStream cr; cr; nextPutAll: '<your descriptive text goes here>"'.
    ^ aStream contents
"Smalltalk changes preambleTemplate"! !


!ChangeSet methodsFor: 'private'!
atClass: class add: changeType

    (self isNew: class) ifFalse:     "new classes don't matter"
        [(classChanges at: class name
                ifAbsent: [^classChanges at: class name put:
                    (Set with: changeType)])
            add: changeType]! !

!ChangeSet methodsFor: 'private'!
atClass: class includes: changeType

    ^(classChanges at: class name ifAbsent: [^false])
        includes: changeType! !

!ChangeSet methodsFor: 'private'!
atSelector: selector class: class

    ^(methodChanges at: class name ifAbsent: [^#none])
        at: selector ifAbsent: [#none]! !

!ChangeSet methodsFor: 'private'!
atSelector: selector class: class put: changeType
    | dict |
    (self isNew: class) ifTrue: [^self].     "Don't keep method changes for new classes"
    (selector==#DoIt) | (selector==#DoItIn:) ifTrue: [^self].
    (methodChanges at: class name
        ifAbsent:
            [dict _ IdentityDictionary new.
            methodChanges at: class name put: dict.
            dict])
        at: selector put: changeType ! !

!ChangeSet methodsFor: 'private' stamp: 'di 6/28/97 20:34'!
fileOutClassDefinition: class on: stream
    "Write out class definition for the given class on the given stream, if the class definition was added or changed.  5/15/96 sw"

    ((self atClass: class includes: #add) or: [self atClass: class includes: #change])
        ifTrue:
            [stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3']! !

!ChangeSet methodsFor: 'private' stamp: 'tk 12/15/97 14:49'!
fileOutClassModifications: class on: stream
    "Write out class mod-- rename, comment, reorg, remove, on the given stream.  Differs from the superseded fileOutClassChanges:on: in that it does not deal with class definitions, and does not file out entire added classes.
     : put out a rename indicator that won't halt if class of old name not there."

    | commentRemoteStr header |
    (self atClass: class includes: #rename) ifTrue:
        [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr].

    (self atClass: class includes: #comment) ifTrue:
        [commentRemoteStr _ class theNonMetaClass organization commentRemoteStr.
        commentRemoteStr ifNotNil: [
            stream cr; nextPut: $!!.    "directly"
            "Should be saying (file command: 'H3') for HTML, but ignoring it here"
            header _ String streamContents: [:strm |
                strm nextPutAll: class theNonMetaClass name;
                nextPutAll: ' commentStamp: '.
                Utilities changeStamp storeOn: strm.
                strm nextPutAll: ' prior: '; nextPutAll: '0'].
            stream nextChunkPut: header; cr.

            RemoteString
                newString: commentRemoteStr text
                onFileNumber: nil
                toFile: stream.
            stream cr]].

    (self atClass: class includes: #reorganize) ifTrue:
        [class fileOutOrganizationOn: stream.
        stream cr]! !

!ChangeSet methodsFor: 'private'!
inspectMethodChanges
    methodChanges inspect! !

!ChangeSet methodsFor: 'private'!
isNew: class
    "Answer whether this class was added since the ChangeSet was cleared."

    (class isKindOf: Metaclass)
        ifTrue: [^self atClass: class soleInstance includes: #add "check class"]
        ifFalse: [^self atClass: class includes: #add]! !

!ChangeSet methodsFor: 'private'!
oldNameFor: class
    | cName |
    cName _ (classChanges at: class name) asOrderedCollection
                detect: [:x | 'oldName: *' match: x].
    ^ (Scanner new scanTokens: cName) last! !


!ChangeSet methodsFor: 'accessing' stamp: 'tk 5/4/1998 17:00'!
editPreamble
    "edit the receiver's preamble, in a separate window.  "

    self assurePreambleExists.
    preamble openLabel: 'Preamble for ChangeSet named ', name! !

!ChangeSet methodsFor: 'accessing'!
methodChanges
    ^methodChanges! !

!ChangeSet methodsFor: 'accessing' stamp: 'di 6/15/97 09:45'!
methodRemoves
    ^methodRemoves! !

!ChangeSet methodsFor: 'accessing'!
name: anObject
    name _ anObject! !

!ChangeSet methodsFor: 'accessing'!
printOn: aStream
    "2/7/96 sw: provide the receiver's name in the printout"
    super printOn: aStream.
    aStream nextPutAll: ' named ', self name! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeSet class
    instanceVariableNames: ''!

!ChangeSet class methodsFor: 'fileIn/Out'!
superclassOrder: classes
    "Arrange the classes in the collection, classes, in superclass order so the
    classes can be properly filed in."

    | all list i aClass superClass |
    list _ classes copy.             "list is indexable"
    all _ OrderedCollection new: list size.
    [list size > 0]
        whileTrue:
            [aClass _ list first.
            superClass _ aClass superclass.
            "Make sure it doesn't have an as yet uncollected superclass"
            [superClass == nil or: [list includes: superClass]]
                whileFalse: [superClass _ superClass superclass].
            i _ 1.
            [superClass == nil]
                whileFalse:
                    [i _ i + 1.
                    aClass _ list at: i.
                    superClass _ aClass superclass.
                    "check as yet uncollected superclass"
                    [superClass == nil or: [list includes: superClass]]
                        whileFalse: [superClass _ superClass superclass]].
            all addLast: aClass.
            list _ list copyWithout: aClass].
    ^all! !


!ChangeSet class methodsFor: 'defaults' stamp: 'di 5/6/1998 16:40'!
defaultName
    | namesInUse try |
    namesInUse _ ChangeSorter gatherChangeSets
                    collect: [:each | each name].
    1 to: 999999 do:
        [:i | try _ 'Unnamed' , i printString.
        (namesInUse includes: try) ifFalse: [^ try]]! !
StringHolder subclass: #ChangeSorter
    instanceVariableNames: 'parent myChangeSet currentClassName currentSelector '
    classVariableNames: 'AllChangeSets '
    poolDictionaries: ''
    category: 'Interface-Changes'!
!ChangeSorter commentStamp: 'di 5/22/1998 16:32' prior: 0!
I display a ChangeSet.  Two of me are in a DualChangeSorter.!


!ChangeSorter methodsFor: 'creation' stamp: 'tk 4/29/1998 10:15'!
defaultBackgroundColor

    ^ #lightBlue! !

!ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 09:38'!
open
    "ChangeSorterPluggable new open"
    | topView |
    World ifNotNil: [^ self openAsMorph].
    Sensor leftShiftDown ifTrue: [^ self openAsMorph].   "testing"

    topView _ StandardSystemView new.
    topView model: self.
    myChangeSet ifNil: [self myChangeSet: Smalltalk changes].
    topView label: self labelString.
    topView borderWidth: 1; minimumSize: 360@360.
    self openView: topView offsetBy: 0@0.
    topView controller open.
! !

!ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 09:42'!
openAsMorph
    "ChangeSorter new openAsMorph"
    |  window |

    myChangeSet ifNil: [self myChangeSet: Smalltalk changes].
    window _ (SystemWindow labelled: self labelString) model: self.
    self openAsMorphIn: window rect: (0@0 extent: 1@1).
    World ifNil: [^ window openInMVC].  "test"
    window openInWorld! !

!ChangeSorter methodsFor: 'creation' stamp: 'tk 5/12/1998 13:17'!
openAsMorphIn: window rect: rect
    "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0."
    | buttonView col |
    contents _ ''.
    self addDependent: window.        "so it will get changed: #relabel"
    buttonView _ PluggableButtonMorph
        on: self
        getState: #mainButtonState
        action: #changeSetMenuStart
        label: #mainButtonName
        menu: #changeSetMenu:.
    col _ Color perform: self defaultBackgroundColor.
    buttonView
        label: myChangeSet name;
        onColor: col offColor: col;
        triggerOnMouseDown: true; borderColor: window color.
    window addMorph: buttonView
        frame: (((0@0 extent: 1.0@0.06) scaleBy: rect extent) translateBy: rect origin).

    window addMorph: (PluggableListMorphByItem on: self
            list: #classList
            selected: #currentClassName
            changeSelected: #currentClassName:
            menu: #classMenu:)
        frame: (((0@0.06 extent: 0.5@0.3) scaleBy: rect extent) translateBy: rect origin).

    window addMorph: (PluggableListMorphByItem on: self
            list: #messageList
            selected: #currentSelector
            changeSelected: #currentSelector:
            menu: #messageMenu:shifted:
            keystroke: #messageListKey:from:)
        frame: (((0.5@0.06 extent: 0.5@0.3) scaleBy: rect extent) translateBy: rect origin).

    window addMorph: (PluggableTextMorph on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
        frame: (((0@0.36 corner: 1@1) scaleBy: rect extent) translateBy: rect origin).
! !

!ChangeSorter methodsFor: 'creation' stamp: 'di 5/6/1998 17:25'!
openView: topView offsetBy: offset
    "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0."
    | classView messageView codeView buttonView |
    contents _ ''.
    self addDependent: topView.        "so it will get changed: #relabel"
    buttonView _ PluggableButtonView
        on: self
        getState: #mainButtonState
        action: #changeSetMenuStart
        label: #mainButtonName
        menu: #changeSetMenu:.
    buttonView
        label: myChangeSet name;
        triggerOnMouseDown: true; borderWidth: 1;
        window: ((0 @ 0 extent: 360 @ 20) translateBy: offset).
    topView addSubView: buttonView.

    classView _ PluggableListViewByItem on: self
        list: #classList
        selected: #currentClassName
        changeSelected: #currentClassName:
        menu: #classMenu:.
    classView window: (0 @ 0 extent: 180 @ 160).
    topView addSubView: classView below: buttonView.

    messageView _ PluggableListViewByItem on: self
        list: #messageList
        selected: #currentSelector
        changeSelected: #currentSelector:
        menu: #messageMenu:shifted:
        keystroke: #messageListKey:from:.
    messageView window: (0 @ 0 extent: 180 @ 160).
    topView addSubView: messageView toRightOf: classView.

    codeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
    codeView window: (0 @ 0 extent: 360 @ 180).
    topView addSubView: codeView below: classView.! !


!ChangeSorter methodsFor: 'access' stamp: 'tk 4/29/1998 08:22'!
changeSet
    ^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 13:37'!
label
    ^ self labelString! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/30/1998 14:03'!
labelString
    "The label for my entire window.  The large button that displays my name is gotten via mainButtonName"
    ^ parent
        ifNil: [Smalltalk changes == myChangeSet
            ifTrue: ['Changes go to "', myChangeSet name, '"']
            ifFalse: ['ChangeSet: ', myChangeSet name]]
        ifNotNil: ['Changes go to "', (Smalltalk changes name), '"']! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 09:10'!
myChangeSet
    ^ myChangeSet! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:43'!
myChangeSet: anObject
    myChangeSet _ anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'!
parent
    ^ parent! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 4/24/1998 08:42'!
parent: anObject
    parent _ anObject! !

!ChangeSorter methodsFor: 'access' stamp: 'tk 5/19/1998 16:23'!
showChangeSet: chgSet

    myChangeSet == chgSet ifFalse: [
        myChangeSet _ chgSet.
        currentClassName _ nil.
        currentSelector _ nil].
    self changed: #relabel.
    self changed: #mainButtonName.
    self changed: #classList.
    self changed: #messageList.
    self setContents.
    self changed: #contents.! !


!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:27'!
browseChangeSet
    "Open a message list browser on the new and changed methods in the current change set"

    ChangedMessageSet openFor: myChangeSet

! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:20'!
changeSetMenu: aMenu
    "Could be for a single or double changeSorter"
    parent ifNotNil: [
    ^ aMenu labels:
'make changes go to me
new...
file into new...
show...
update
fileOut
browse
rename
copy all to other side
submerge into other side
subtract other side
edit preamble...
edit postscript...
clear
remove'
        lines: #(1 3 8 11 13 )
        selections: #(newCurrent newSet fileIntoNewChangeSet chooseCngSet update fileOut browseChangeSet rename copyAllToOther submergeIntoOtherSide subtractOtherSide editPreamble editPostscript clearChangeSet remove )]

    ifNil: ["Single ChangeSorter"
    ^ aMenu labels:
'make changes go to me
new...
file into new...
show...
update
fileOut
browse
rename
edit preamble...
edit postscript...
clear
remove'
        lines: #(1 3 8 10)
        selections: #(newCurrent newSet fileIntoNewChangeSet chooseCngSet update fileOut browseChangeSet rename editPreamble editPostscript clearChangeSet remove )]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'jm 5/20/1998 12:15'!
changeSetMenuStart

    | menu |
    menu _ self changeSetMenu: CustomMenu new.
    menu ifNotNil: [menu invokeOn: self].
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:15'!
chooseCngSet
    "Put up a list of them"
    | index |

    self okToChange ifFalse: [^ self].
    ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets].
    index _ (PopUpMenu labels:
        (AllChangeSets collect: [:each | each name]) asStringWithCr) startUp.
    index = 0 ifFalse: [self showChangeSet: (AllChangeSets at: index)].! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:06'!
clearChangeSet
    "Clear out the current change set, after getting a confirmation."
    | message |

    self okToChange ifFalse: [^ self].
    myChangeSet isEmpty ifFalse:
        [message _ 'Are you certain that you want to\forget all the changes in this set?' withCRs.
        (self confirm: message) ifFalse: [^ self]].
    myChangeSet clear.
    self changed: #classList.
    self changed: #messageList.
    self setContents.
    self changed: #contents.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:29'!
copyAllToOther
    "Copy this entire change set into the one on the other side"
    | other nextToView ii |

    other _ (parent other: self) myChangeSet.
    other assimilateAllChangesFoundIn: myChangeSet.
    (parent other: self) changed: #classList.    "Later the changeSet itself will notice..."
    (parent other: self) changed: #messageList.

    nextToView _ ((AllChangeSets includes: myChangeSet)
            and: [(ii _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size])
        ifTrue: [AllChangeSets at: ii+1]
        ifFalse: [myChangeSet].
    self showChangeSet: nextToView! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPostscript
    "Allow the user to edit the receiver's change-set's postscript -- in a separate window"

    myChangeSet editPostscript! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:06'!
editPreamble
    "Allow the user to edit the receiver's change-set's preamble -- in a separate window."

    myChangeSet editPreamble! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:16'!
fileIntoNewChangeSet
    "Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename.  Show the new set and leave the current changeSet unaltered."
    | aFileName  aNewChangeSet |

    self okToChange ifFalse: [^ self].
    aFileName _ FillInTheBlank request: 'Name of file to be imported: '.
    aFileName size == 0 ifTrue: [^ self].
    (FileDirectory default fileExists: aFileName) ifFalse:
        [^ self inform: 'Sorry -- cannot find that file'].

    aNewChangeSet _ self class
            newChangesFromStream: (FileStream oldFileNamed: aFileName)
            named: aFileName.
    aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:26'!
fileOut
    "File out the current change set."

    myChangeSet fileOut! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:10'!
mainButtonName

    ^ myChangeSet name! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 10:11'!
mainButtonState
    "The button activates the menu, but does not stay on"
    ^ false! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/30/1998 13:47'!
newCurrent
    "make my change set be the current one that changes go into"
    Smalltalk newChanges: myChangeSet.
    self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:16'!
newSet
    "Create a new changeSet and show it.  make the new guy the current one.  Also, reject name if already in use."
    | newName newSet |

    self okToChange ifFalse: [^ self].
    newName _ FillInTheBlank request: 'A name for the new change set'
            initialAnswer: ChangeSet defaultName.
    newName isEmpty ifTrue: [^ self].
    (self class changeSetNamed: newName) ifNotNil:
            [^ self inform: 'Sorry that name is already used'].

    newSet _ ChangeSet new initialize name: newName.
    AllChangeSets add: newSet.
    self showChangeSet: newSet.
    self newCurrent.
! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 09:07'!
remove
    "Completely destroy my change set.  Check if it's OK first"

    self okToChange ifFalse: [^ self].
    self removePrompting: true! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/24/1998 13:48'!
removePrompting: doPrompt
    "Completely destroy my change set.  Check if it's OK first,  and if doPrompt is true, get the user to confirm his intentions first"
    | message aName |

    aName _ myChangeSet name.
    myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project"
    (myChangeSet isEmpty or: [doPrompt not]) ifFalse:
        [message _ 'Are you certain that you want to
remove (destroy) the change set
named  "', aName, '" ?'.
        (self confirm: message) ifFalse: [^ self]].

    "Go ahead and remove the change set"
    AllChangeSets remove: myChangeSet.
    myChangeSet wither.        "clear out its contents"
    self showChangeSet: Smalltalk changes.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 08:38'!
rename
    "Store a new name string into the selected ChangeSet.  reject duplicate name; allow user to back out"

    | newName |
    newName _ FillInTheBlank request: 'New name for this change set'
                        initialAnswer: myChangeSet name.
    (newName = myChangeSet name or: [newName size == 0]) ifTrue:
            [^ self inform: 'No change made'].

    (self class changeSetNamed: newName) ifNotNil:
            [^ Utilities inform: 'Sorry that name is already used'].

    myChangeSet name: newName.
    self changed: #mainButtonName.
    self changed: #relabel.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:26'!
submergeIntoOtherSide
    "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well."
    | other message nextToView i |

    self okToChange ifFalse: [^ self].
    other _ (parent other: self) changeSet.
    other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!'].
    myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy.  To remove,
simply choose "remove".'].

    myChangeSet okayToRemove ifFalse: [^ self].
    message _ 'Please confirm:  copy all changes
in "', myChangeSet name, '" into "', other name, '"
and then destroy the change set
named "', myChangeSet name, '"?'.

    (self confirm: message) ifFalse: [^ self].
    other assimilateAllChangesFoundIn: myChangeSet.

    nextToView _ ((AllChangeSets includes: myChangeSet)
        and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size])
        ifTrue: [AllChangeSets at: i+1]
        ifFalse: [other].

    self removePrompting: false.
    self showChangeSet: nextToView.
    self class gatherChangeSets.
    (parent other: self) changed: #classList.
    (parent other: self) changed: #messageList.! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/29/1998 08:33'!
subtractOtherSide
    "Subtract the changes found on the other side from the requesting side."

    myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet).
    self showChangeSet: myChangeSet! !

!ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 4/28/1998 20:58'!
update
    "recompute all of my panes"

    self okToChange ifFalse: [^ self].
    self showChangeSet: myChangeSet.
    parent ifNotNil: [
        (parent other: self) okToChange ifTrue: [
            (parent other: self) showChangeSet:
                (parent other: self) myChangeSet]].! !


!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:01'!
classList
    "Computed.  View should try to preserve selections, even though index changes"

    ^ myChangeSet changedClassNames
! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/29/1998 09:57'!
classMenu: aMenu
    "Could be for a single or double changeSorter"
    parent ifNotNil: [
        ^ aMenu labels:
'copy to other side
delete from this change set
browse full
inst var refs...
inst var defs...
class var refs...
class vars'
        lines: #(2 3 )
        selections: #(copyClassToOther forgetClass browseMethodFull browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables)]

    ifNil: [
        ^ aMenu labels:
'delete from this change set
browse full
inst var refs...
inst var defs...
class var refs...
class vars'
        lines: #(1 2 )
        selections: #(forgetClass browseMethodFull browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables)]! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 14:29'!
copyClassToOther
    "Place these changes in the other changeSet also"
    | other info cls |

    other _ (parent other: self) changeSet.
    (myChangeSet classRemoves includes: currentClassName) ifTrue: [
            ^ other noteRemovalOf: currentClassName].

    info _ myChangeSet classChangeAt: (cls _ self selectedClassOrMetaClass) name.
    info do: [:each | other atClass: cls add: each].

    info _ myChangeSet methodChanges at: cls name ifAbsent: [Dictionary new].
    info associationsDo: [:ass |
        other atSelector: ass key class: cls put: ass value].
    (parent other: self) showChangeSet: other.! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 09:14'!
currentClassName

    ^ currentClassName! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/19/1998 12:41'!
currentClassName: aString

    currentClassName _ aString.
    currentSelector _ nil.    "fix by wod"
    self changed: #currentClassName.
    self changed: #messageList.
    self setContents.
    self changed: #contents.! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/20/1998 17:20'!
forgetClass
    "Remove all mention of this class from the changeSet"

    self okToChange ifFalse: [^ self].
    currentClassName ifNotNil: [
        myChangeSet removeClassChanges: self selectedClassOrMetaClass.
        currentClassName _ nil.
        currentSelector _ nil.
        self showChangeSet: myChangeSet].
! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 4/24/1998 10:48'!
selectedClass

    ^ currentClassName ifNil: [nil]
        ifNotNil: [self selectedClassOrMetaClass theNonMetaClass]! !

!ChangeSorter methodsFor: 'class list' stamp: 'tk 5/7/1998 13:48'!
selectedClassOrMetaClass
    "Careful, the class may have been removed!!"

    | cName |
    currentClassName ifNil: [^ nil].
    (currentClassName endsWith: ' class')
        ifTrue: [cName _ (currentClassName copyFrom: 1 to: currentClassName size-6) asSymbol.
                ^ (Smalltalk at: cName ifAbsent: [^nil]) class]
        ifFalse: [cName _ currentClassName asSymbol.
                ^ Smalltalk at: cName ifAbsent: [nil]]! !


!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 18:49'!
browseVersions
    "Create and schedule a changelist browser on the versions of the
    selected message."
    | class selector method category pair sourcePointer |

    (selector _ self selectedMessageName) ifNil: [^ self].
    class _ self selectedClassOrMetaClass.
    (class includesSelector: selector)
        ifTrue: [method _ class compiledMethodAt: selector.
                category _ class whichCategoryIncludesSelector: selector.
                sourcePointer _ nil]
        ifFalse: [pair _ myChangeSet methodRemoves
                            at: (Array with: class name with: selector)
                            ifAbsent: [^ nil].
                sourcePointer _ pair first.
                method _ CompiledMethod toReturnSelf setSourcePointer: sourcePointer.
                category _ pair last].
    ChangeList
        browseVersionsOf: method
        class: self selectedClass meta: class isMeta
        category: category selector: selector
        lostMethodPointer: sourcePointer.
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:08'!
copyMethodToOther
    "Place this change in the other changeSet also"
    | other info cls sel |

    currentSelector ifNotNil: [
        other _ (parent other: self) changeSet.
        cls _ self selectedClassOrMetaClass.
        sel _ currentSelector asSymbol.

        info _ myChangeSet methodChanges at: cls name ifAbsent: [Dictionary new].
        other atSelector: sel
            class: cls
            put: (info at: sel).
        (parent other: self) showChangeSet: other]
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/24/1998 09:15'!
currentSelector

    ^ currentSelector! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 20:48'!
currentSelector: messageName

    currentSelector _ messageName.
    self changed: #currentSelector.
    self setContents.
    self changed: #contents.! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:11'!
forget
    "Drop this method from the changeSet"

    self okToChange ifFalse: [^ self].
    currentSelector ifNotNil: [
        myChangeSet removeSelectorChanges: self selectedMessageName
            class: self selectedClassOrMetaClass.
        self showChangeSet: myChangeSet]! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/26/1998 22:34'!
messageList

    | probe |
    currentClassName ifNil: [^ #()].
    probe _ (currentClassName endsWith: ' class')
        ifTrue: [currentClassName]
        ifFalse: [currentClassName asSymbol].
    ^ ((myChangeSet selectorsInClass: probe) collect:
                    [:each | each printString]) asSortedCollection
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/29/1998 10:03'!
messageMenu: aMenu shifted: shifted
    "Could be for a single or double changeSorter"
    shifted ifTrue: [^ self shiftedMessageMenu: aMenu].
    parent ifNotNil: [
        ^ aMenu labels:
'copy method to other side
delete method from change set
remove method from system
browse full
fileOut
printOut
senders of...
implementors of...
versions
more...'
        lines: #(1 3 6 9 )
        selections: #(copyMethodToOther forget removeMessage browseMethodFull fileOutMessage printOutMessage browseSendersOfMessages browseMessages browseVersions shiftedYellowButtonActivity )]

    ifNil: [^ aMenu labels:
'delete method from change set
remove method from system
browse full
fileOut
printOut
senders of...
implementors of...
versions
more...'
        lines: #(2 5 8 )
        selections: #( forget removeMessage browseMethodFull fileOutMessage printOutMessage browseSendersOfMessages browseMessages browseVersions shiftedYellowButtonActivity )]
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 5/18/1998 10:23'!
removeMessage
    "Remove the selected msg from the system.  Real work done by the parent, a ChangeSorter"

    | confirmation sel |
    self okToChange ifFalse: [^ self].
    currentSelector ifNotNil: [
        confirmation _ self selectedClassOrMetaClass
            confirmRemovalOf: (sel _ self selectedMessageName).
        confirmation == 3 ifTrue: [^ self].
        myChangeSet removeSelectorChanges: sel
            class: self selectedClassOrMetaClass.
        self selectedClassOrMetaClass removeSelector: sel.
        self update.
    "    self changed: #messageList.
        self setContents.
        self changed: #contents.
    "
        confirmation == 2 ifTrue:
            [Smalltalk browseAllCallsOn: sel]]! !

!ChangeSorter methodsFor: 'message list' stamp: 'jm 5/4/1998 07:32'!
selectedMessageName

    currentSelector ifNil: [^ nil].
    ^ currentSelector asSymbol! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:02'!
shiftedMessageMenu: aMenu

    ^ aMenu labels: 'browse class hierarchy
browse class
browse method
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
more...'
    lines: #(5 7 10)
    selections: #(classHierarchy browseClass
        buildMessageBrowser browseAllMessages findMethodInChangeSets
        inspectInstances inspectSubInstances
        unshiftedYellowButtonActivity)! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:03'!
shiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self messageMenu: (CustomMenu new) shifted: true.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !

!ChangeSorter methodsFor: 'message list' stamp: 'tk 4/28/1998 19:16'!
unshiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self messageMenu: (CustomMenu new) shifted: false.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !


!ChangeSorter methodsFor: 'code pane' stamp: 'tk 5/18/1998 11:43'!
contents: aString notifying: aController
    "Compile the code in aString. Notify aController of any syntax errors.
    Create an error if the category of the selected message is unknown.
    Answer false if the compilation fails. Otherwise, if the compilation
    created a new method, deselect the current selection. Then answer true."
    | category selector class oldSelector |

    (class _ self selectedClassOrMetaClass) ifNil: [^ false].
    oldSelector _ self selectedMessageName.
    category _ class organization categoryOfElement: oldSelector.
    selector _ class compile: aString
                classified: category
                notifying: aController.
    selector ifNil: [^ false].
    (self messageList includes: selector)
        ifTrue: [self currentSelector: selector]
        ifFalse: [self currentSelector: oldSelector].
    self update.
    ^ true! !

!ChangeSorter methodsFor: 'code pane' stamp: 'tk 5/18/1998 14:40'!
setContents
    "return the source code that shows in the bottom pane"
    | sel class strm changeType |
    self clearUserEditFlag.
    currentClassName ifNil: [^ contents _ ''].
    class _ self selectedClassOrMetaClass.
    (sel _ currentSelector) == nil
        ifFalse: [changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class).
            changeType == #remove
                ifTrue: [^ contents _ 'Method has been removed (see versions)'].
            changeType == #addedThenRemoved
                ifTrue: [^ contents _ 'Added then removed (see versions)'].
            class ifNil: [^ contents _ 'Method was added, but cannot be found!!'].
            (class includesSelector: sel)
                ifFalse: [^ contents _ 'Method was added, but cannot be found!!'].
            ^ contents _ (class sourceMethodAt: sel) copy]
        ifTrue: [strm _ WriteStream on: (String new: 100).
            (myChangeSet classChangeAt: currentClassName) do: [:each |
                each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr].
                each = #add ifTrue: [strm nextPutAll: 'Entire class was added.'; cr].
                each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr].
                each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr]].
            ^ contents _ strm contents].! !

!ChangeSorter methodsFor: 'code pane' stamp: 'di 5/22/1998 14:09'!
spawn: aString
    "Create and schedule a message browser for the receiver in which the
    argument, aString, contains characters to be edited in the text view."

    currentSelector ifNil: [^ self].
    ^ Browser
        openMessageBrowserForClass: self selectedClassOrMetaClass
        selector: self selectedMessageName
        editString: aString! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeSorter class
    instanceVariableNames: ''!

!ChangeSorter class methodsFor: 'all' stamp: 'tk 5/1/1998 15:26'!
allChangeSetNames
    ^ self gatherChangeSets collect: [:c | c name]! !

!ChangeSorter class methodsFor: 'all' stamp: 'di 5/6/1998 16:40'!
browseChangeSetsWithClass: class selector: selector
    | hits index |
    hits _ self gatherChangeSets select:
        [:cs | (cs atSelector: selector class: class) ~~ #none].
    hits isEmpty ifTrue: [^ PopUpMenu notify: class name,'.',selector , '
is not in any change set'].
    index _ hits size == 1
        ifTrue:    [1]
        ifFalse:    [(PopUpMenu labelArray: (hits collect: [:cs | cs name])
                    lines: #()) startUp].
    index = 0 ifTrue: [^ self].
    (ChangeSorter new myChangeSet: (hits at: index)) open.
! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 16:42'!
changeSetNamed: aName
    "Return the change set of the given name, or nil if none found.  1/22/96 sw"

    self gatherChangeSets.
    AllChangeSets do:
        [:aChangeSet | aChangeSet name = aName ifTrue:
            [^ aChangeSet]].
    ^ nil! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:51'!
gatherChangeSets
    "Collect any change sets created in other projects"

    ChangeSet allInstancesDo: [:each |
        (AllChangeSets includes: each) ifFalse:
            [AllChangeSets add: each]].
    ^ AllChangeSets _ AllChangeSets select:
        [:each | each isMoribund not]

    "ChangeSorter gatherChangeSets"! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 5/1/1998 22:34'!
highestNumberedChangeSet
    "ChangeSorter highestNumberedChangeSet"
    ^ (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect:
        [:aString | aString initialInteger]) max
! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:52'!
initialize
    AllChangeSets == nil ifTrue:
        [AllChangeSets _ OrderedCollection new].
    self gatherChangeSets.
! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 4/24/1998 13:19'!
newChangesFromStream: aFileStream named: aFileName
    "File in the code from the file, into a new change set whose name is derived from the filename.  Leave the 'current change set' unchanged.   Returns the new change set;  Returns nil on failure."

    |  newName aNewChangeSet existingChanges |

    existingChanges _ Smalltalk changes.
    newName _ aFileName sansPeriodSuffix.
    (self changeSetNamed: newName) ~~ nil
        ifTrue:
            [self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.
            aFileStream close.
            ^ nil].

    aNewChangeSet _ ChangeSet new initialize.
    aNewChangeSet name: newName.
    AllChangeSets add: aNewChangeSet.
    Smalltalk newChanges: aNewChangeSet.
    aFileStream fileIn.
    Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.
    Smalltalk newChanges: existingChanges.
    ^ aNewChangeSet! !

!ChangeSorter class methodsFor: 'all' stamp: 'jm 5/22/1998 11:33'!
removeChangeSetsBefore: stopName
    "Remove all change sets before the one with the given name."
    "ChangeSorter removeChangeSetsBefore: 'Beyond'"

    | stop |
    (self confirm:
'Really remove all change sets before
"', stopName, '"?')
        ifFalse: [^ self].

    self gatherChangeSets.
    stop _ false.
    ChangeSet allInstancesDo: [:changeSet |
        changeSet name = stopName ifTrue: [stop _ true].
        stop ifFalse: [
            changeSet okayToRemove ifTrue: [
                AllChangeSets remove: changeSet ifAbsent: [].
                changeSet wither]]].
    Smalltalk garbageCollect.
    AllChangeSets _ OrderedCollection new.
    self gatherChangeSets.
! !

!ChangeSorter class methodsFor: 'all' stamp: 'di 5/12/1998 12:20'!
removeChangeSetsNamedSuchThat: nameBlock
    "ChangeSorter removeChangeSetsNamedSuchThat:
        [:name | name first isDigit and: [name initialInteger >= 275]]"
    self allChangeSetNames do:
        [:csName | (nameBlock value: csName) ifTrue: [AllChangeSets remove: (self changeSetNamed: csName) wither]]! !

!ChangeSorter class methodsFor: 'all' stamp: 'jm 5/20/1998 10:40'!
removeOldChangeSets
    "Ask the user to select a change set from a menu, then remove all change sets before the selected one."
    "ChangeSorter removeOldChangeSets"

    | names stopName |
    self gatherChangeSets.
    names _ AllChangeSets collect: [:each | each name].
    stopName _ (SelectionMenu labelList: names selections: names) startUp.
    stopName ifNotNil: [self removeChangeSetsBefore: stopName].
! !

!ChangeSorter class methodsFor: 'all' stamp: 'tk 4/30/1998 13:43'!
secondaryChangeSet
    "Answer a likely change set to use as the second initial one in a Dual Change Sorter.  "
    | last |
    self gatherChangeSets.
    AllChangeSets size == 1 ifTrue: [^ AllChangeSets first].
    ^ (last _ AllChangeSets last) == Smalltalk changes
        ifTrue:     [AllChangeSets at: (AllChangeSets size - 1)]
        ifFalse:    [last]! !
MessageSet subclass: #ChangedMessageSet
    instanceVariableNames: 'changeSet '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Browser'!

!ChangedMessageSet methodsFor: 'everything'!
changeSet: aChangeSet
    changeSet _ aChangeSet! !

!ChangedMessageSet methodsFor: 'everything' stamp: 'tk 4/26/1998 09:20'!
contents: aString notifying: aController
    | selectedMessageName selector oldMessageList cls |
    selectedMessageName _ self selectedMessageName.
    oldMessageList _ self messageList.
    contents _ nil.
    selector _ self selectedClassOrMetaClass
                compile: aString
                classified:  self selectedMessageCategoryName
                notifying: aController.
    selector == nil ifTrue: [^ false].
    cls _ self selectedClassOrMetaClass.
    contents _ aString copy.
    selector ~~ selectedMessageName ifTrue:
            [(oldMessageList includes: selector) ifFalse: [
                    self initializeMessageList: changeSet changedMessageListAugmented.
                    self changed: #messageList].
            self messageListIndex: (self messageList indexOf: (cls name, ' ', selector))].
    ^ true! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangedMessageSet class
    instanceVariableNames: ''!

!ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sw 3/9/97'!
openFor: aChangeSet
    "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message list is the list of methods in aChangeSet.  After any method submission, the message list is refigured, making it plausibly dynamic.  "
    | messageSet |

    messageSet _ self messageList: aChangeSet changedMessageListAugmented.
    messageSet changeSet: aChangeSet.
    messageSet autoSelectString: nil.
    ScheduledControllers scheduleActive:
                    (self open: messageSet name:  'Methods in Change Set ', aChangeSet name)! !
Object subclass: #CharRecog
    instanceVariableNames: 'mp p sts pts bmin bmax op cPat in dirs ftrs prevFeatures '
    classVariableNames: 'CharacterDictionary '
    poolDictionaries: 'TextConstants '
    category: 'System-Support'!
!CharRecog commentStamp: 'di 5/22/1998 16:32' prior: 0!
CharRecog comment:
'Alan Kay''s "one-page" character recognizer.  Currently hooked up to text panes, such that you can get it started by hitting cmd-r in any pane.

To reinitialize the recognition dictionary, evaluate

    CharRecog reinitializeCharacterDictionary

 '!


!CharRecog methodsFor: 'recognizer'!
directionFrom: p1 to: p2 | ex |

"This does 8 directions and is not used in current recognizer"
"get the bounding box"        ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"                ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"            ((ex y = 0) or: [(ex x/ex y) abs > 2]) ifTrue:
    "look for w-e"                    [ex x > 0 ifTrue:[^' we-- ']
    "it's an e-w"                        ifFalse:[^' ew-- ']].
"look for vertical line"        ((ex x = 0) or: [(ex y/ex x) abs > 2]) ifTrue:
    "look for n-s"                [(ex y > 0) ifTrue:[ ^' ns||']
    "it's a s-n"                        ifFalse:[^' sn|| ']].
"look for a diagonal"            (ex x/ex y) abs <= 2 ifTrue:
    "se or ne"                    [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// '].
    "sw or nw"                                    ex y > 0 ifTrue:[^' sw// ']. ^' nw// '].
! !

!CharRecog methodsFor: 'recognizer'!
extractFeatures | xl xr yl yh reg px py |
"get extent bounding box"    in _ bmax - bmin.

"Look for degenerate forms first: . - |"
"look for a dot"                in < (3@3) ifTrue: [^' dot... '].

"Feature 5: turns (these are already in ftrs)"

"Feature 4: absolute size"    in < (10@10) ifTrue: [ftrs _  'SML ', ftrs] ifFalse:
                            [in <=  (70@70) ifTrue: [ftrs _ 'REG ', ftrs] ifFalse:
                            [in > (70@70) ifTrue: [ftrs _ 'LRG ', ftrs]]].

"Feature 3: aspect ratio"
    "horizontal shape"        ((in y = 0) or: [(in x/in y) abs > 3]) ifTrue:
                                [ftrs _ 'HOR ', ftrs] ifFalse:
    "vertical shape"            [((in x = 0) or: [(in y/in x) abs >= 3]) ifTrue:
                                [ftrs _ 'VER ', ftrs] ifFalse:
    "boxy shape"            [((in x/in y) abs <= 3) ifTrue:
                                [ftrs _ 'BOX ', ftrs.
"Now only for boxes"
"Feature 2: endstroke reg"    ftrs _ (self regionOf: (pts last)), ftrs.

"Feature 1: startstroke reg"    ftrs _ (self regionOf: (pts contents at: 1)), ftrs.]]].

^ftrs



! !

!CharRecog methodsFor: 'recognizer'!
fourDirsFrom:  p1 to: p2 | ex |

"get the bounding box"        ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"                ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"            ((ex y = 0) or: [(ex x/ex y) abs > 1]) ifTrue:
    "look for w-e"                    [ex x > 0 ifTrue:[^'WE ']
    "it's an e-w"                        ifFalse:[^'EW ']].
"look for vertical line"        ((ex x = 0) or: [(ex y/ex x) abs >= 1]) ifTrue:
    "look for n-s"                [(ex y > 0) ifTrue:[ ^'NS ']
    "it's a s-n"                        ifFalse:[^'SN ']].

"look for a diagonal            (ex x/ex y) abs <= 2 ifTrue:"
    "se or ne                    [ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']."
    "sw or nw                                    ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']."
! !

!CharRecog methodsFor: 'recognizer' stamp: 'jm 4/28/1998 05:37'!
learnPrev
    "The character recognized before this one was wrong.  (Got here via the gesture for 'wrong'.)  Bring up a dialog box on that char.  8/21/96 tk"

                        | old result |
    old _ CharacterDictionary at: prevFeatures ifAbsent: [^ ''].
"get right char from user"    result _ FillInTheBlank request:
                        ('Redefine the gesture we thought was "', old asString, '".', '
(Letter or:  tab  cr  wrong  bs  select  caret)
', prevFeatures).

"ignore or..."                (result = '~' | result = '') ifTrue: ['']
"...enter new char"            ifFalse: [
                                CharacterDictionary at: prevFeatures
                                    put: result].
                    "caller erases bad char"
"good char"            ^ result! !

!CharRecog methodsFor: 'recognizer'!
recognize | prv cdir result features char r s t dir |

"Alan Kay's recognizer as of 1/31/96.  This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar.  Within the current image, the recognizer is now called via #recognizeAndDispatch:until:"


"Inits"                (p _ Pen new) defaultNib: 1; down.
    "for points"        pts _ ReadWriteStream on: #().

"Event Loop"
                    [(Sensor mousePoint x) < 50] whileFalse:

"First-Time"            [pts reset.
"will hold features"        ftrs _ ''.

                      (Sensor anyButtonPressed) ifTrue:
                        [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
                        p place: sts. cdir _ nil.

"Each-Time"        [Sensor anyButtonPressed] whileTrue:
                        [
"ink raw input"            p goto: (r _ Sensor mousePoint).
"smooth it"                s _ (0.5*s) + (0.5*r).
"thin the stream"        ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
                            [ pts nextPut: t.
"bounding box"            bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"                dir _ (self fourDirsFrom: t to: s). t _ s.
                            dir ~= ' dot... ' ifTrue: [
"store new dirs"                    cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's"             p place: t; go: 1; place: r.
                            ].
 "End Each-Time Loop"    ].

"Last-Time"

"save last points"        pts nextPut: t; nextPut: r.
"find rest of features"    features _ self extractFeatures.
"find char..."            char _ CharacterDictionary at: features ifAbsent:
"...or get from user"            [ result _ FillInTheBlank request:
                             'Not recognized. type char, or type ~: ', features.
"ignore or..."                result = '~' ifTrue: ['']
"...enter new char"            ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"        (char = 'cr' ifTrue: [Transcript cr] ifFalse:
                        [char = 'bs' ifTrue: [Transcript bs] ifFalse:
                        [char = 'tab' ifTrue:[Transcript tab] ifFalse:
                        [Transcript show: char]]]).

"End First-Time Loop"    ].

"End Event-Loop" ].


 ! !

!CharRecog methodsFor: 'recognizer'!
recognizeAndDispatch: charDispatchBlock ifUnrecognized: unrecognizedFeaturesBlock until: terminationBlock
    "Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true.  This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method.  2/2/96 sw.   2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window.  8/17/96 tk: Turn cr, tab, bs into strings so they work.
     9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt.  unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none."

    | prv cdir features char r s t dir |

"Inits"                (p _ Pen new) defaultNib: 1; down.
    "for points"        pts _ ReadWriteStream on: #().

"Event Loop"
                    [terminationBlock value] whileFalse:

"First-Time"            [pts reset.
"will hold features"        ftrs _ ''.

                      (Sensor anyButtonPressed) ifTrue:
                        [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
                        p place: sts. cdir _ nil.

"Each-Time"        [Sensor anyButtonPressed] whileTrue:
"ink raw input"            [p goto: (r _ Sensor mousePoint).
"smooth it"                s _ (0.5*s) + (0.5*r).
"thin the stream"        ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
                            [pts nextPut: t.
"bounding box"                bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"                dir _ (self fourDirsFrom: t to: s). t _ s.
                            dir ~= ' dot... ' ifTrue:
"store new dirs"                    [cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's"                 p place: t; go: 1; place: r]].
 "End Each-Time Loop"

"Last-Time"
"save last points"        pts nextPut: t; nextPut: r.
"find rest of features"    features _ self extractFeatures.
"find char..."            char _ CharacterDictionary at: features ifAbsent:
                            [unrecognizedFeaturesBlock value: features].

"special chars"        char size > 0 ifTrue:
                        [char = 'tab' ifTrue: [char _ Tab].
                        char = 'cr' ifTrue:    [char _ CR].
"must be a string"        char class == Character ifTrue:
                            [char _ String with: char].
                        char = 'bs' ifTrue:    [char _ BS].
"control the editor"        charDispatchBlock value: char]]]
 ! !

!CharRecog methodsFor: 'recognizer'!
recognizeAndDispatch: charDispatchBlock until: terminationBlock
    "Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. 9/18/96 sw"

    ^ self recognizeAndDispatch: charDispatchBlock
        ifUnrecognized:
            [:features | self stringForUnrecognizedFeatures: features]
        until: terminationBlock
 ! !

!CharRecog methodsFor: 'recognizer'!
recognizeAndPutInTranscript
    "Call Alan's recognizer repeatedly until the mouse is near the left edge of the screen, and dispatch keystrokes inferred to the Trancript.  2/2/96 sw"

    ^ self recognizeAndDispatch:

        [:char | (char = 'cr') ifTrue: [Transcript cr] ifFalse:
                        [char = 'bs' ifTrue: [Transcript bs] ifFalse:
                        [char = 'tab' ifTrue:[Transcript tab] ifFalse:
                        [Transcript show: char]]]]

        until:
            [Sensor mousePoint x < 50]

"CharRecog new recognizeAndPutInTranscript"! !

!CharRecog methodsFor: 'recognizer'!
recogPar | prv cdir result features char r s t dir |

"Inits"                (p _ Pen new) defaultNib: 1; down.
    "for points"        pts _ ReadWriteStream on: #().

"Event Loop"
        [Sensor anyButtonPressed] whileFalse: [(Sensor mousePoint x < 50) ifTrue: [^''].].

"First-Time"            pts reset.
"will hold features"        ftrs _ ''.

                      (Sensor anyButtonPressed) ifTrue:
                        [pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
                        p place: sts. cdir _ nil.

"Each-Time"        [Sensor anyButtonPressed] whileTrue:
                        [
"ink raw input"            p goto: (r _ Sensor mousePoint).
"smooth it"                s _ (0.5*s) + (0.5*r).
"thin the stream"        ((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
                            [ pts nextPut: t.
"bounding box"            bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"                dir _ (self fourDirsFrom: t to: s). t _ s.
                            dir ~= ' dot... ' ifTrue: [
"store new dirs"                    cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's"             p place: t; go: 1; place: r.
                            ].
 "End Each-Time Loop"    ].

"Last-Time"
"start a new recog for next point"    [CharRecog new recognize] fork.

"save last points"        pts nextPut: t; nextPut: r.
"find rest of features"    features _ self extractFeatures.
"find char..."            char _ CharacterDictionary at: features ifAbsent:
"...or get from user"            [ result _ FillInTheBlank request:
                             'Not recognized. type char, or type ~: ', features.
"ignore or..."                result = '~' ifTrue: ['']
"...enter new char"            ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"        (char = 'cr' ifTrue: [Transcript cr] ifFalse:
                        [char = 'bs' ifTrue: [Transcript bs] ifFalse:
                        [char = 'tab' ifTrue:[Transcript tab] ifFalse:
                        [Transcript show: char]]]).

"End First-Time Loop"    ].




 ! !

!CharRecog methodsFor: 'recognizer'!
regionOf: pt

| px py reg xl yl yh xr rg |
"it's some other character"    rg _ in/3.     xl _ bmin x + rg x. xr _ bmax x - rg x.
"divide box into 9 regions"                yl _ bmin y + rg y. yh _ bmax y - rg y.

                    px _ pt x. py _ pt y.
                    reg _ (px < xl ifTrue: [py < yl ifTrue: ['NW ']
                                        "py >= yl"    ifFalse:[ py < yh ifTrue:['W ']
                                                                    ifFalse: ['SW ']]]
                    ifFalse: [px < xr ifTrue: [py < yl ifTrue: ['N ']
                                                    ifFalse: [py < yh ifTrue: ['C ']
                                                                    ifFalse: ['S ']]]
                    ifFalse: [py < yl ifTrue: ['NE ']
                                    ifFalse: [py < yh ifTrue: ['E ']
                                                    ifFalse: ['SE ']]]]).
^reg.
                    ! !

!CharRecog methodsFor: 'recognizer' stamp: 'jm 4/28/1998 05:37'!
stringForUnrecognizedFeatures: features
    "Prompt the user for what string the current features represent, and return the result.  9/18/96 sw"

    | result |
    result _ FillInTheBlank request:
('Not recognized. type char, or "tab", "cr" or "bs",
or hit return to ignore
', features).

    ^ (result = '~' | result = '')
        ifTrue:
            ['']
        ifFalse:
            [CharacterDictionary at: features put: result. result]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CharRecog class
    instanceVariableNames: ''!

!CharRecog class methodsFor: 'initialization'!
initialize
    "Iniitialize the character dictionary if it doesn't exist yet.  2/5/96 sw"

    CharacterDictionary == nil ifTrue:
        [CharacterDictionary _ Dictionary new]! !

!CharRecog class methodsFor: 'initialization'!
reinitializeCharacterDictionary
    "Reset the character dictionary to be empty, ready for a fresh start.  2/5/96 sw"

    CharacterDictionary _ Dictionary new

"CharRecog reinitializeCharacterDictionary" ! !


!CharRecog class methodsFor: 'saving dictionary'!
readRecognizerDictionaryFrom: aFileName
    "Read a fresh version of the Recognizer dictionary in from a file of the given name.  7/26/96 sw"
    "CharRecog readRecognizerDictionaryFrom: 'RecogDictionary.2 fixed'"

   | aReferenceStream |
   aReferenceStream _ ReferenceStream fileNamed: aFileName.
   CharacterDictionary _ aReferenceStream next.
   aReferenceStream close.
! !

!CharRecog class methodsFor: 'saving dictionary'!
saveRecognizerDictionaryTo: aFileName
    "Save the current state of the Recognizer dictionary to disk.  7/26/96 sw"

   | aReferenceStream |
aReferenceStream _ ReferenceStream fileNamed: aFileName.
   aReferenceStream nextPut: CharacterDictionary.
   aReferenceStream close! !
Magnitude subclass: #Character
    instanceVariableNames: 'value '
    classVariableNames: 'CharacterTable '
    poolDictionaries: ''
    category: 'Collections-Text'!
!Character commentStamp: 'di 5/22/1998 16:32' prior: 0!
Character comment:
'I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.'!


!Character methodsFor: 'accessing'!
asciiValue
    "Answer the value of the receiver that represents its ascii encoding."

    ^value! !

!Character methodsFor: 'accessing'!
digitValue
    "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0
    otherwise. This is used to parse literal numbers of radix 2-36."

    value <= $9 asciiValue
        ifTrue: [^value - $0 asciiValue].
    value >= $A asciiValue
        ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].
    ^ -1! !


!Character methodsFor: 'comparing'!
< aCharacter
    "Answer true if the receiver's value < aCharacter's value."

    ^self asciiValue < aCharacter asciiValue! !

!Character methodsFor: 'comparing'!
= aCharacter
    "Primitive. Answer true if the receiver and the argument are the same
    object (have the same object pointer) and false otherwise. Optional. See
    Object documentation whatIsAPrimitive."

    <primitive: 110>
    ^self == aCharacter! !

!Character methodsFor: 'comparing'!
> aCharacter
    "Answer true if the receiver's value > aCharacter's value."

    ^self asciiValue > aCharacter asciiValue! !

!Character methodsFor: 'comparing'!
hash
    "Hash is reimplemented because = is implemented."

    ^value! !


!Character methodsFor: 'testing'!
isAlphaNumeric
    "Answer whether the receiver is a letter or a digit."

    ^self isLetter or: [self isDigit]! !

!Character methodsFor: 'testing'!
isDigit
    "Answer whether the receiver is a digit."

    ^value >= 48 and: [value <= 57]! !

!Character methodsFor: 'testing'!
isLetter
    "Answer whether the receiver is a letter."

    ^(8r141 <= value and: [value <= 8r172])
        or: [8r101 <= value and: [value <= 8r132]]! !

!Character methodsFor: 'testing'!
isLowercase
    "Answer whether the receiver is a lowercase letter.
    (The old implementation answered whether the receiver is not an uppercase letter.)"

    ^8r141 <= value and: [value <= 8r172]! !

!Character methodsFor: 'testing'!
isSeparator
    "Answer whether the receiver is one of the separator characters--space,
    cr, tab, line feed, or form feed."

    value = 32 ifTrue: [^true].    "space"
    value = 13 ifTrue: [^true].    "cr"
    value = 9 ifTrue: [^true].    "tab"
    value = 10 ifTrue: [^true].    "line feed"
    value = 12 ifTrue: [^true].    "form feed"
    ^false! !

!Character methodsFor: 'testing'!
isSpecial
    "Answer whether the receiver is one of the special characters"

    ^'+/\*~<>=@%|&?!!' includes: self! !

!Character methodsFor: 'testing'!
isUppercase
    "Answer whether the receiver is an uppercase letter.
    (The old implementation answered whether the receiver is not a lowercase letter.)"

    ^8r101 <= value and: [value <= 8r132]! !

!Character methodsFor: 'testing'!
isVowel
    "Answer whether the receiver is one of the vowels, AEIOU, in upper or
    lower case."

    ^'AEIOU' includes: self asUppercase! !

!Character methodsFor: 'testing'!
tokenish
    "Answer whether the receiver is a valid token-character--letter, digit, or
    colon."

    ^self isLetter or: [self isDigit or: [self = $:]]! !


!Character methodsFor: 'copying'!
copy
    "Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'copying'!
deepCopy
    "Answer with the receiver because Characters are unique."! !


!Character methodsFor: 'printing'!
hex
    ^ String with: ('0123456789ABCDEF' at: value//16+1)
            with:  ('0123456789ABCDEF' at: value\\16+1)! !

!Character methodsFor: 'printing'!
isLiteral

    ^true! !

!Character methodsFor: 'printing'!
printOn: aStream

    aStream nextPut: $$.
    aStream nextPut: self! !

!Character methodsFor: 'printing'!
storeOn: aStream
    "Character literals are preceded by '$'."

    aStream nextPut: $$; nextPut: self! !


!Character methodsFor: 'converting'!
asCharacter
    "Answer the receiver itself."

    ^self! !

!Character methodsFor: 'converting'!
asInteger
    "Answer the value of the receiver."

    ^value! !

!Character methodsFor: 'converting'!
asLowercase
    "If the receiver is uppercase, answer its matching lowercase Character."

    (8r101 <= value and: [value <= 8r132])  "self isUppercase"
        ifTrue: [^ Character value: value + 8r40]
        ifFalse: [^ self]! !

!Character methodsFor: 'converting'!
asString
    | cString |
    cString _ String new: 1.
    cString at: 1 put: self.
    ^ cString! !

!Character methodsFor: 'converting'!
asSymbol
    "Answer a Symbol consisting of the receiver as the only element."

    ^Symbol internCharacter: self! !

!Character methodsFor: 'converting'!
asUppercase
    "If the receiver is lowercase, answer its matching uppercase Character."

    (8r141 <= value and: [value <= 8r172])  "self isLowercase"
        ifTrue: [^ Character value: value - 8r40]
        ifFalse: [^ self]! !

!Character methodsFor: 'converting'!
to: other
    "Answer with a collection in ascii order -- $a to: $z"
    ^ (self asciiValue to: other asciiValue) collect:
                [:ascii | Character value: ascii]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Character class
    instanceVariableNames: ''!

!Character class methodsFor: 'class initialization'!
initialize
    "Create the table of unique Characters. This code is not shown so that the
    user can not destroy the system by trying to recreate the table."! !


!Character class methodsFor: 'instance creation'!
digitValue: x
    "Answer the Character whose digit value is x. For example, answer $9 for
    x=9, $0 for x=0, $A for x=10, $Z for x=35."

    | index |
    index _ x asInteger.
    ^CharacterTable at:
        (index < 10
            ifTrue: [48 + index]
            ifFalse: [55 + index])
        + 1! !

!Character class methodsFor: 'instance creation'!
new
    "Creating new characters is not allowed."

    self error: 'cannot create new characters'! !

!Character class methodsFor: 'instance creation'!
separators
    ^ #(32 "space"
        13 "cr"
        9 "tab"
        10 "line feed"
        12 "form feed")
        collect: [:v | Character value: v]


! !

!Character class methodsFor: 'instance creation'!
value: anInteger
    "Answer the Character whose value is anInteger."

    ^CharacterTable at: anInteger + 1! !


!Character class methodsFor: 'accessing untypeable characters'!
backspace
    "Answer the Character representing a backspace."

    ^self value: 8! !

!Character class methodsFor: 'accessing untypeable characters'!
cr
    "Answer the Character representing a carriage return."

    ^self value: 13! !

!Character class methodsFor: 'accessing untypeable characters'!
enter
    "Answer the Character representing enter."

    ^self value: 3! !

!Character class methodsFor: 'accessing untypeable characters'!
linefeed
    "Answer the Character representing a linefeed."

    ^self value: 10! !

!Character class methodsFor: 'accessing untypeable characters'!
newPage
    "Answer the Character representing a form feed."

    ^self value: 12! !

!Character class methodsFor: 'accessing untypeable characters'!
space
    "Answer the Character representing a space."

    ^self value: 32! !

!Character class methodsFor: 'accessing untypeable characters'!
tab
    "Answer the Character representing a tab."

    ^self value: 9! !


!Character class methodsFor: 'constants' stamp: 'tk 12/11/97 09:29'!
alphabet
    ^ 'abdcefghijklmnopqrstuvwxyz'! !

!Character class methodsFor: 'constants'!
characterTable
    "Answer the class variable in which unique Characters are stored."

    ^CharacterTable! !
Rectangle subclass: #CharacterBlock
    instanceVariableNames: 'stringIndex text textLine '
    classVariableNames: ''
    poolDictionaries: 'TextConstants '
    category: 'Graphics-Support'!
!CharacterBlock commentStamp: 'di 5/22/1998 16:32' prior: 0!
CharacterBlock comment:
'My instances contain information about displayed characters. They are used to return the results of methods:
    Paragraph characterBlockAtPoint: aPoint and
    Paragraph characterBlockForIndex: stringIndex.
Any recomposition or movement of a Paragraph can make the instance obsolete.'!


!CharacterBlock methodsFor: 'accessing'!
stringIndex
    "Answer the position of the receiver in the string it indexes."

    ^stringIndex! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine
    ^ textLine! !

!CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'!
textLine: aLine
    textLine _ aLine! !


!CharacterBlock methodsFor: 'comparing'!
< aCharacterBlock
    "Answer whether the string index of the receiver precedes that of
    aCharacterBlock."

    ^stringIndex < aCharacterBlock stringIndex! !

!CharacterBlock methodsFor: 'comparing'!
<= aCharacterBlock
    "Answer whether the string index of the receiver does not come after that
    of aCharacterBlock."

    ^(self > aCharacterBlock) not! !

!CharacterBlock methodsFor: 'comparing'!
= aCharacterBlock

    self species = aCharacterBlock species
        ifTrue: [^stringIndex = aCharacterBlock stringIndex]
        ifFalse: [^false]! !

!CharacterBlock methodsFor: 'comparing'!
> aCharacterBlock
    "Answer whether the string index of the receiver comes after that of
    aCharacterBlock."

    ^aCharacterBlock < self! !

!CharacterBlock methodsFor: 'comparing'!
>= aCharacterBlock
    "Answer whether the string index of the receiver does not precede that of
    aCharacterBlock."

    ^(self < aCharacterBlock) not! !


!CharacterBlock methodsFor: 'printing' stamp: 'di 12/2/97 19:15'!
printOn: aStream

    aStream nextPutAll: 'a CharacterBlock with index '.
    stringIndex printOn: aStream.
    (text ~~ nil and: [text size> 0 and: [stringIndex between: 1 and: text size]])
        ifTrue: [aStream nextPutAll: ' and character '.
                (text at: stringIndex) printOn: aStream].
    aStream nextPutAll: ' and rectangle '.
    super printOn: aStream.
    textLine ifNotNil: [aStream cr; nextPutAll: ' in '.
                textLine printOn: aStream].
! !


!CharacterBlock methodsFor: 'private'!
moveBy: aPoint
    "Change the corner positions of the receiver so that its area translates by
    the amount defined by the argument, aPoint."

    origin _ origin + aPoint.
    corner _ corner + aPoint! !

!CharacterBlock methodsFor: 'private' stamp: 'di 10/23/97 22:33'!
stringIndex: anInteger text: aText topLeft: topLeft extent: extent

    stringIndex _ anInteger.
    text _ aText.
    super setOrigin: topLeft corner: topLeft + extent ! !
CharacterScanner subclass: #CharacterBlockScanner
    instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth '
    classVariableNames: ''
    poolDictionaries: 'TextConstants '
    category: 'Graphics-Support'!
!CharacterBlockScanner commentStamp: 'di 5/22/1998 16:32' prior: 0!
CharacterBlockScanner comment:
'My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.'!


!CharacterBlockScanner methodsFor: 'scanning'!
characterBlockAtPoint: aPoint in: aParagraph
    "Answer a CharacterBlock for character in aParagraph at point aPoint. It
    is assumed that aPoint has been transformed into coordinates appropriate
    to the text's destination form rectangle and the composition rectangle."

    super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
    characterPoint _ aPoint.
    ^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'di 12/2/97 14:30'!
characterBlockAtPoint: aPoint index: index in: textLine
    | runLength lineStop done stopCondition |
    line _ textLine.
    characterIndex _ index.  " == nil means scanning for point"
    characterPoint _ aPoint.
    (characterPoint == nil or: [characterPoint y > line bottom])
        ifTrue: [characterPoint _ line bottomRight].
    (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left])
                or: [characterIndex ~~ nil and: [characterIndex < line first]]])
        ifTrue:    [^ (CharacterBlock new stringIndex: line first text: text
                    topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid)
                    textLine: line].
    rightMargin _ line rightMargin.
    destX _ leftMargin _ line leftMarginForAlignment: textStyle alignment.
    destY _ line top.
    lastIndex _ line first.
    self setStopConditions.        "also sets font"
    runLength _ text runLengthFor: line first.
    characterIndex ~~ nil
        ifTrue:    [lineStop _ characterIndex  "scanning for index"]
        ifFalse:    [lineStop _ line last  "scanning for point"].
    runStopIndex _ lastIndex + (runLength - 1) min: lineStop.
    lastCharacterExtent _ 0 @ line lineHeight.
    spaceCount _ 0.

    done  _ false.
    [done] whileFalse:
        [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
            in: text string rightX: characterPoint x
            stopConditions: stopConditions kern: kern displaying: false.
        "see setStopConditions for stopping conditions for character block     operations."
        self lastCharacterExtentSetX: (specialWidth == nil
            ifTrue: [font widthOf: (text at: lastIndex)]
            ifFalse: [specialWidth]).
        (self perform: stopCondition) ifTrue:
            [^ (CharacterBlock new
                stringIndex: (characterIndex==nil ifTrue: [lastIndex] ifFalse: [characterIndex])
                text: text topLeft: characterPoint extent: lastCharacterExtent)
                textLine: line]]! !

!CharacterBlockScanner methodsFor: 'scanning'!
characterBlockForIndex: targetIndex in: aParagraph
    "Answer a CharacterBlock for character in aParagraph at targetIndex. The
    coordinates in the CharacterBlock will be appropriate to the intersection
    of the destination form rectangle and the composition rectangle."

    super
        initializeFromParagraph: aParagraph
        clippedBy: aParagraph clippingRectangle.
    characterIndex _ targetIndex.
    characterPoint _
        aParagraph rightMarginForDisplay @
            (aParagraph topAtLineIndex:
                (aParagraph lineIndexOfCharacterIndex: characterIndex)).
    ^self buildCharacterBlockIn: aParagraph! !

!CharacterBlockScanner methodsFor: 'scanning'!
characterNotInFont
    "This does not handle character selection nicely, i.e., illegal characters are a
    little tricky to select.  Since the end of a run or line is subverted here by actually
    having the scanner scan a different string in order to manage the illegal
    character, things are not in an absolutely correct state for the character
    location code.  If this becomes too odious in use, logic will be added to accurately
    manage the situation."

    lastCharacterExtent _
        (font widthOf: (font maxAscii + 1) asCharacter) @ line lineHeight.
    ^super characterNotInFont! !

!CharacterBlockScanner methodsFor: 'scanning' stamp: 'di 11/12/97 19:34'!
placeEmbeddedObject: anchoredMorph
    (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
    specialWidth _ width.
    ^ true! !


!CharacterBlockScanner methodsFor: 'stop conditions'!
cr
    "Answer a CharacterBlock that specifies the current location of the mouse
    relative to a carriage return stop condition that has just been
    encountered. The ParagraphEditor convention is to denote selections by
    CharacterBlocks, sometimes including the carriage return (cursor is at
    the end) and sometimes not (cursor is in the middle of the text)."

    ((characterIndex ~= nil
        and: [characterIndex > text size])
            or: [(line last = text size)
                and: [(destY + line lineHeight) < characterPoint y]])
        ifTrue:    ["When off end of string, give data for next character"
                destY _ destY +  line lineHeight.
                lastCharacter _ nil.
                characterPoint _ ((text at: lastIndex) = CR
                                ifTrue: [leftMargin]
                                ifFalse: [nextLeftMargin]) @ destY.
                lastIndex _ lastIndex + 1.
                self lastCharacterExtentSetX: 0.
                ^ true].
        lastCharacter _ CR.
        characterPoint _ destX @ destY.
        self lastCharacterExtentSetX: rightMargin - destX.
        ^true! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'di 11/7/97 12:20'!
crossedX
    "Text display has wrapping. The scanner just found a character past the x
    location of the cursor. We know that the cursor is pointing at a character
    or before one."

    | leadingTab currentX |
    characterPoint x <= (destX + ((lastCharacterExtent x) // 2))
        ifTrue:    [lastCharacter _ (text at: lastIndex).
                characterPoint _ destX @ destY.
                ^true].
    lastIndex >= line last
        ifTrue:    [lastCharacter _ (text at: line last).
                characterPoint _ destX @ destY.
                ^true].
    "Pointing past middle of a character, return the next character."
    lastIndex _ lastIndex + 1.
    lastCharacter _ text at: lastIndex.
    currentX _ destX + lastCharacterExtent x.
    self lastCharacterExtentSetX: (font widthOf: lastCharacter).
    characterPoint _ currentX @ destY.

    "Yukky if next character is space or tab."
    (lastCharacter = Space and: [textStyle alignment = Justified])
        ifTrue:    [self lastCharacterExtentSetX:
                    (lastCharacterExtent x +     (line justifiedPadFor: (spaceCount + 1))).
                ^ true].
    lastCharacter = Space
        ifTrue:
            ["See tabForDisplay for illumination on the following awfulness."
            leadingTab _ true.
            (line first to: lastIndex - 1) do:
            [:index |
            (text at: index) ~= Tab
                ifTrue: [leadingTab _ false]].
            (textStyle alignment ~= Justified or: [leadingTab])
                ifTrue:    [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX
                            leftMargin: leftMargin rightMargin: rightMargin) -
                                currentX]
                ifFalse:    [self lastCharacterExtentSetX:  (((currentX + (textStyle tabWidth -
                                (line justifiedTabDeltaFor: spaceCount))) -
                                    currentX) max: 0)]].
    ^ true
! !

!CharacterBlockScanner methodsFor: 'stop conditions'!
endOfRun
    "Before arriving at the cursor location, the selection has encountered an
    end of run. Answer false if the selection continues, true otherwise. Set
    up indexes for building the appropriate CharacterBlock."

    | runLength lineStop |
    ((characterIndex ~~ nil and:
        [runStopIndex < characterIndex and: [runStopIndex < text size]])
            or:    [characterIndex == nil and: [lastIndex < line last]])
        ifTrue:    ["We're really at the end of a real run."
                runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
                characterIndex ~~ nil
                    ifTrue:    [lineStop _ characterIndex    "scanning for index"]
                    ifFalse:    [lineStop _ line last            "scanning for point"].
                (runStopIndex _ lastIndex + (runLength - 1)) > lineStop
                    ifTrue:     [runStopIndex _ lineStop].
                self setStopConditions.
                ^false].

    lastCharacter _ text at: lastIndex.
    characterPoint _ destX @ destY.
    ((lastCharacter = Space and: [textStyle alignment = Justified])
        or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]])
        ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent].
    characterIndex ~~ nil
        ifTrue:    ["If scanning for an index and we've stopped on that index,
                then we back destX off by the width of the character stopped on
                (it will be pointing at the right side of the character) and return"
                runStopIndex = characterIndex
                    ifTrue:    [self characterPointSetX: destX - lastCharacterExtent x.
                            ^true].
                "Otherwise the requested index was greater than the length of the
                string.  Return string size + 1 as index, indicate further that off the
                string by setting character to nil and the extent to 0."
                lastIndex _  lastIndex + 1.
                lastCharacter _ nil.
                self lastCharacterExtentSetX: 0.
                ^true].

    "Scanning for a point and either off the end of the line or off the end of the string."
    runStopIndex = text size
        ifTrue:    ["off end of string"
                lastIndex _  lastIndex + 1.
                lastCharacter _ nil.
                self lastCharacterExtentSetX: 0.
                ^true].
    "just off end of line without crossing x"
    lastIndex _ lastIndex + 1.
    ^true! !

!CharacterBlockScanner methodsFor: 'stop conditions'!
paddedSpace
    "When the line is justified, the spaces will not be the same as the font's
    space character. A padding of extra space must be considered in trying
    to find which character the cursor is pointing at. Answer whether the
    scanning has crossed the cursor."

    | pad |
    pad _ 0.
    spaceCount _ spaceCount + 1.
    pad _ line justifiedPadFor: spaceCount.
    lastSpaceOrTabExtent _ lastCharacterExtent copy.
    self lastSpaceOrTabExtentSetX:  spaceWidth + pad.
    (destX + lastSpaceOrTabExtent x)  >= characterPoint x
        ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
                ^self crossedX].
    lastIndex _ lastIndex + 1.
    destX _ destX + lastSpaceOrTabExtent x.
    ^ false
! !

!CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'di 11/11/97 08:50'!
setFont
    specialWidth _ nil.
    super setFont! !

!CharacterBlockScanner methodsFor: 'stop conditions'!
setStopConditions
    "Set the font and the stop conditions for the current run."

    self setFont.
    stopConditions at: (Space asciiValue + 1) put:
        (textStyle alignment = Justified ifTrue: [#paddedSpace] ifFalse: [nil])! !

!CharacterBlockScanner methodsFor: 'stop conditions'!
tab
    | currentX |
    currentX _ (textStyle alignment == Justified and: [self leadingTab not])
        ifTrue:        "imbedded tabs in justified text are weird"
            [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX]
        ifFalse:
            [textStyle
                nextTabXFrom: destX
                leftMargin: leftMargin
                rightMargin: rightMargin].
    lastSpaceOrTabExtent _ lastCharacterExtent copy.
    self lastSpaceOrTabExtentSetX: (currentX - destX max: 0).
    currentX >= characterPoint x
        ifTrue:
            [lastCharacterExtent _ lastSpaceOrTabExtent copy.
            ^ self crossedX].
    destX _ currentX.
    lastIndex _ lastIndex + 1.
    ^false! !


!CharacterBlockScanner methodsFor: 'private' stamp: 'di 12/2/97 14:30'!
buildCharacterBlockIn: para
    | lineIndex runLength lineStop done stopCondition |
    "handle nullText"
    (para numberOfLines = 0 or: [text size = 0])
        ifTrue:    [^ CharacterBlock new stringIndex: 1  "like being off end of string"
                    text: para text
                    topLeft: (para leftMarginForDisplayForLine: 1)
                                @ para compositionRectangle top
                    extent: 0 @ textStyle lineGrid].
    "find the line"
    lineIndex _ para lineIndexOfTop: characterPoint y.
    destY _ para topAtLineIndex: lineIndex.
    line _ para lines at: lineIndex.
    rightMargin _ para rightMarginForDisplay.

    (lineIndex = para numberOfLines and:
        [(destY + line lineHeight) < characterPoint y])
            ifTrue:    ["if beyond lastLine, force search to last character"
                    self characterPointSetX: rightMargin]
            ifFalse:    [characterPoint y < (para compositionRectangle) top
                        ifTrue: ["force search to first line"
                                characterPoint _ (para compositionRectangle) topLeft].
                    characterPoint x > rightMargin
                        ifTrue:    [self characterPointSetX: rightMargin]].
    destX _ leftMargin _ para leftMarginForDisplayForLine: lineIndex.
    nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1.
    lastIndex _ line first.

    self setStopConditions.        "also sets font"
    runLength _ (text runLengthFor: line first).
    characterIndex ~~ nil
        ifTrue:    [lineStop _ characterIndex    "scanning for index"]
        ifFalse:    [lineStop _ line last].
    (runStopIndex _ lastIndex + (runLength - 1)) > lineStop
        ifTrue:    [runStopIndex _ lineStop].
    lastCharacterExtent _ 0 @ line lineHeight.
    spaceCount _ 0. done  _ false.

    [done]
    whileFalse:
    [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
            in: text string rightX: characterPoint x
            stopConditions: stopConditions kern: kern displaying: false.

    "see setStopConditions for stopping conditions for character block     operations."
    self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)).
    (self perform: stopCondition)
        ifTrue:    [^ CharacterBlock new stringIndex: lastIndex text: text
                    topLeft: characterPoint extent: lastCharacterExtent]]! !

!CharacterBlockScanner methodsFor: 'private'!
characterPointSetX: xVal
    characterPoint _ xVal @ characterPoint y! !

!CharacterBlockScanner methodsFor: 'private'!
lastCharacterExtentSetX: xVal
    lastCharacterExtent _ xVal @ lastCharacterExtent y! !

!CharacterBlockScanner methodsFor: 'private'!
lastSpaceOrTabExtentSetX: xVal
    lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! !
BitBlt subclass: #CharacterScanner
    instanceVariableNames: 'lastIndex xTable stopConditions text textStyle leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern '
    classVariableNames: ''
    poolDictionaries: 'TextConstants '
    category: 'Graphics-Support'!
!CharacterScanner commentStamp: 'di 5/22/1998 16:32' prior: 0!
CharacterScanner comment:
'My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.'!


!CharacterScanner methodsFor: 'scanning' stamp: 'di 10/29/97 12:16'!
characterNotInFont
    "All fonts have an illegal character to be used when a character is not
    within the font's legal range. When characters out of ranged are
    encountered in scanning text, then this special character indicates the
    appropriate behavior. The character is usually treated as a unary
    message understood by a subclass of CharacterScanner."

    | illegalAsciiString saveIndex stopCondition |
    saveIndex _ lastIndex.
    illegalAsciiString _ String with: (font maxAscii + 1) asCharacter.
    stopCondition _ self scanCharactersFrom: 1 to: 1
            in: illegalAsciiString
            rightX: rightMargin stopConditions: stopConditions
            kern: kern displaying: self doesDisplaying.
    lastIndex _ saveIndex + 1.
    stopCondition ~= (stopConditions at: EndOfRun)
        ifTrue:    [^self perform: stopCondition]
        ifFalse: [lastIndex = runStopIndex
                    ifTrue:    [^self perform: (stopConditions at: EndOfRun)].
                ^false]
! !

!CharacterScanner methodsFor: 'scanning' stamp: 'jm 11/19/97 23:15'!
ifCharIn: str at: i fits: segLen do: fonCharWidthBlock
    "Scan a character of text, tracking font changes, and return true,
    unless the character won't fit or it is off the end of the string."
    "No kerning yet..."
    | ascii char maxAscii |
    i > str size ifTrue: [^ false].
    (runStopIndex == nil or: [i > runStopIndex]) ifTrue:
        [runStopIndex _ i + (text runLengthFor: i) - 1.
        lastIndex _ i.
        self setFont].
    maxAscii _ xTable size-2.
    ascii _ (char _ str at: i) asciiValue min: maxAscii.
    width _ (xTable at: ascii + 2) - (xTable at: ascii + 1).
    width > segLen ifTrue: [^ false].
    fonCharWidthBlock value: font value: char value: width.
    ^ true! !

!CharacterScanner methodsFor: 'scanning'!
leadingTab
    "return true if only tabs lie to the left"
    line first to: lastIndex do:
        [:i | (text at: i) == Tab ifFalse: [^ false]].
    ^ true! !

!CharacterScanner methodsFor: 'scanning' stamp: 'di 11/17/97 15:08'!
placeEmbeddedObject: anchoredMorph
    "Place the anchoredMorph or return false if it cannot be placed.
    In any event, advance destX by its width."

    destX _ destX + (width _ anchoredMorph width).
    (destX > rightMargin and: [(leftMargin + width) <= rightMargin])
        ifTrue: ["Won't fit, but would on next line"
                ^ false].
    runStopIndex _ lastIndex.  "Force new calc of emphasis"
    lastIndex _ lastIndex + 1.
    ^ true! !

!CharacterScanner methodsFor: 'scanning'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops displaying: display
    "Primitive. This is the inner loop of text display--but see
    scanCharactersFrom: to:rightX: which would get the string,
    stopConditions and displaying from the instance. March through source
    String from startIndex to stopIndex. If any character is flagged with a
    non-nil entry in stops, then return the corresponding value. Determine
    width of each character from xTable. If dextX would exceed rightX, then
    return stops at: 258. If displaying is true, then display the character.
    Advance destX by the width of the character. If stopIndex has been
    reached, then return stops at: 257. Fail under the same conditions that
    the Smalltalk code below would cause an error. Optional. See Object
    documentation whatIsAPrimitive."
    | ascii nextDestX maxAscii |
    <primitive: 103>
    maxAscii _ xTable size-2.
    lastIndex _ startIndex.
    [lastIndex <= stopIndex]
        whileTrue:
            [ascii _ (sourceString at: lastIndex) asciiValue.
            "ascii > maxAscii ifTrue: [ascii _ maxAscii]."
            (stopConditions at: ascii + 1) == nil
                ifFalse: [^stops at: ascii + 1].
            sourceX _ xTable at: ascii + 1.
            nextDestX _ destX + (width _ (xTable at: ascii + 2) - sourceX).
            nextDestX > rightX ifTrue: [^stops at: CrossedX].
            display ifTrue: [self copyBits].
            destX _ nextDestX.
            lastIndex _ lastIndex + 1].
    lastIndex _ stopIndex.
    ^stops at: EndOfRun! !

!CharacterScanner methodsFor: 'scanning' stamp: 'di 10/31/97 12:51'!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta displaying: display
    "This method will perform text scanning with non-zero kerning.
    It calls the faster primitive method, if the kern delta is zero.
    Some day we may want to put kerning into the primitive."
    | ascii nextDestX maxAscii fillBlt |
    kernDelta = 0 ifTrue:
        [^ self scanCharactersFrom: startIndex to: stopIndex in: sourceString
                rightX: rightX stopConditions: stops displaying: display].
    display ifTrue: [fillBlt _ self fillBlt].
    maxAscii _ xTable size-2.
    lastIndex _ startIndex.
    [lastIndex <= stopIndex]
        whileTrue:
            [ascii _ (sourceString at: lastIndex) asciiValue.
            ascii > maxAscii ifTrue: [ascii _ maxAscii].
            (stopConditions at: ascii + 1) == nil
                ifFalse: [^stops at: ascii + 1].
            sourceX _ xTable at: ascii + 1.
            nextDestX _ destX + (width _ (xTable at: ascii + 2) - sourceX).
            nextDestX > rightX ifTrue: [^stops at: CrossedX].
            display ifTrue:
                [self copyBits
                fillBlt == nil ifFalse:
                    [fillBlt destX: nextDestX destY: destY
                            width: kernDelta height: height;
                            copyBits]].
            destX _ nextDestX + kernDelta.
            lastIndex _ lastIndex + 1].
    lastIndex _ stopIndex.
    ^stops at: EndOfRun! !


!CharacterScanner methodsFor: 'private'!
addEmphasis: code
    "Set the bold-ital-under-strike emphasis."
    emphasisCode _ emphasisCode bitOr: code! !

!CharacterScanner methodsFor: 'private' stamp: 'di 10/29/97 11:58'!
addKern: kernDelta
    "Set the current kern amount."
    kern _ kern + kernDelta! !

!CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 21:56'!
beginAt: startCharIndex
    lastIndex _ startCharIndex.
    runStopIndex _ lastIndex + (text runLengthFor: lastIndex) - 1.
    self setFont! !

!CharacterScanner methodsFor: 'private'!
doesDisplaying

    ^false! !

!CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 21:56'!
ifNextCharFits: segLen do: fonCharWidthBlock! !

!CharacterScanner methodsFor: 'private'!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

    text _ aParagraph text.
    textStyle _ aParagraph textStyle.
    destForm _ aParagraph destinationForm.
    self fillColor: aParagraph fillColor.    "sets halftoneForm"
    self combinationRule: aParagraph rule.
    self clipRect: clippingRectangle.
    sourceY _ 0! !

!CharacterScanner methodsFor: 'private'!
setActualFont: aFont
    "Set the basal font to an isolated font reference."

    font _ aFont! !

!CharacterScanner methodsFor: 'private' stamp: 'di 10/29/97 12:00'!
setFont
    "Set the font and other emphasis."
    self setFont: 1.
    emphasisCode _ 0.
    kern _ 0.
    (text attributesAt: lastIndex) do:
        [:att | att emphasizeScanner: self].
    font _ font emphasized: emphasisCode.

    "Install various parameters from the font."
    spaceWidth _ font widthOf: Space.
    sourceForm _ font glyphs.  "Should only be needed in DisplayScanner"
    height _ font height.            " ditto "
    xTable _ font xTable.
    stopConditions _ font stopConditions.
    stopConditions at: Space asciiValue + 1 put: #space.
    stopConditions at: Tab asciiValue + 1 put: #tab.
    stopConditions at: CR asciiValue + 1 put: #cr.
    stopConditions at: EndOfRun put: #endOfRun.
    stopConditions at: CrossedX put: #crossedX! !

!CharacterScanner methodsFor: 'private' stamp: 'di 10/24/97 09:05'!
setFont: fontNumber
    "Set the font by number from the textStyle."

    self setActualFont: (textStyle fontAt: fontNumber)! !

!CharacterScanner methodsFor: 'private' stamp: 'jm 11/19/97 20:51'!
setFontAt: startCharIndex
    lastIndex _ startCharIndex.
    self setFont! !

!CharacterScanner methodsFor: 'private' stamp: 'di 10/22/97 11:52'!
text: t textStyle: ts
    text _ t.
    textStyle _ ts! !

!CharacterScanner methodsFor: 'private'!
textColor: ignored
    "Overridden in DisplayScanner"! !
ServerAction subclass: #ChatPage
    instanceVariableNames: 'current '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!ChatPage commentStamp: 'di 5/22/1998 16:32' prior: 0!
Simple ServerAction that allows a primitive chat session shown as a web page.  It maintains a list of the 20 most recent submissions.  There is a form on the page for typing your contribution to the session.

The default Swiki has a chat page enabled.

Get to the page by this URL:
machine:80/chat!


!ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/25/97 13:33'!
add: aMessage
    current isNil ifTrue: [current _ OrderedCollection new].
    current add: aMessage.
    (current size > 20)
        ifTrue: [current _ current copyFrom: (current size - 20) to: (current size)]! !

!ChatPage methodsFor: 'chat processing' stamp: 'mjg 11/17/97 13:32'!
current
    ^current
! !


!ChatPage methodsFor: 'URL processing' stamp: 'mjg 11/25/97 13:34'!
process: request
    | author note |
    request fields isNil
        ifTrue:
            [current isNil ifTrue: [current _ OrderedCollection new].
            request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html')
                    with: current)]
        ifFalse:
            [author _ request fields at: 'author'.
            note _ request fields at: 'note'.
            self add: '<b>' , author , '</b>
            <i>' , Time now printString , '-' , Date today printString , '</i><p>' , note , '<p>'.
            request fields at: 'current' put: current.
            request reply: (HTMLformatter evalEmbedded: (self fileContents: 'chat.html')
                    with: request)]! !
Arc subclass: #Circle
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Paths'!
!Circle commentStamp: 'di 5/22/1998 16:32' prior: 0!
Circle comment:
'I represent a full circle. I am made from four Arcs.'!


!Circle methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

    1 to: 4 do:
        [:i |
        super quadrant: i.
        super displayOn: aDisplayMedium
            at: aPoint
            clippingBox: clipRect
            rule: anInteger
            fillColor: aForm]! !

!Circle methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

    1 to: 4 do:
        [:i |
        super quadrant: i.
        super displayOn: aDisplayMedium
            transformation: aTransformation
            clippingBox: clipRect
            rule: anInteger
            fillColor: aForm]! !


!Circle methodsFor: 'display box access'!
computeBoundingBox

    ^center - radius + form offset extent: form extent + (radius * 2) asPoint! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Circle class
    instanceVariableNames: ''!

!Circle class methodsFor: 'examples'!
exampleOne
    "Click any button somewhere on the screen. The point will be the center
    of the circcle of radius 150."

    | aCircle aForm |
    aForm _ Form extent: 1@30.
    aForm fillBlack.
    aCircle _ Circle new.
    aCircle form: aForm.
    aCircle radius: 150.
    aCircle center: Sensor waitButton.
    aCircle displayOn: Display

    "Circle exampleOne"! !

!Circle class methodsFor: 'examples'!
exampleTwo
    "Designate a rectangular area that should be used as the brush for
    displaying the circle. Click any button at a point on the screen which
    will be the center location for the circle. The curve will be displayed
    with a long black form."

    | aCircle aForm |
    aForm _ Form fromUser.
    aCircle _ Circle new.
    aCircle form: aForm.
    aCircle radius: 150.
    aCircle center: Sensor waitButton.
    aCircle displayOn: Display at: 0 @ 0 rule: Form reverse

     "Circle exampleTwo"! !
ClassDescription subclass: #Class
    instanceVariableNames: 'name classPool sharedPools '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Classes'!
!Class commentStamp: 'di 5/22/1998 16:32' prior: 0!
Class comment:
'My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. An example is accessing shared (pool) variables.'!


!Class methodsFor: 'initialize-release'!
declare: varString
    "Declare class variables common to all instances. Answer whether
    recompilation is advisable."

    | newVars conflicts assoc class |
    newVars _
        (Scanner new scanFieldNames: varString)
            collect: [:x | x asSymbol].
    newVars do:
        [:var | var first isLowercase
            ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
    conflicts _ false.
    classPool == nil
        ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do:
                    [:var | self removeClassVarName: var]].
    (newVars reject: [:var | self classPool includesKey: var])
        do: [:var | "adding"
            "check if new vars defined elsewhere"
            (self scopeHas: var ifTrue: [:ignored | ignored])
                ifTrue:
                    [self error: var , ' is defined elsewhere'.
                    conflicts _ true]].
    newVars size > 0
        ifTrue:
            [classPool _ self classPool.
            "in case it was nil"
            newVars do: [:var | classPool declare: var from: Undeclared]].
    ^conflicts! !

!Class methodsFor: 'initialize-release'!
obsolete
    "Change the receiver to an obsolete class by changing its name to have
    the prefix -AnObsolete-."

    name _ 'AnObsolete' , name.
    classPool _ Dictionary new.
    self class obsolete.
    super obsolete! !

!Class methodsFor: 'initialize-release'!
removeFromSystem
    "Forget the receiver from the Smalltalk global dictionary. Any existing
    instances will refer to an obsolete version of the receiver."

    Smalltalk removeClassFromSystem: self.
    self obsolete! !

!Class methodsFor: 'initialize-release'!
sharing: poolString
    "Set up sharedPools. Answer whether recompilation is advisable."
    | oldPools found |
    oldPools _ self sharedPools.
    sharedPools _ OrderedCollection new.
    (Scanner new scanFieldNames: poolString) do:
        [:poolName |
        sharedPools add: (Smalltalk at: poolName asSymbol)].
    sharedPools isEmpty ifTrue: [sharedPools _ nil].
    oldPools do: [:pool | found _ false.
                self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
                found ifFalse: [^ true "A pool got deleted"]].
    ^ false! !

!Class methodsFor: 'initialize-release'!
superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet
    "Answer an instance of me, a new class, using the arguments of the
    message as the needed information."

    superclass _ sup.
    methodDict _ md.
    format _ ft.
    name _ nm.
    organization _ org.
    instanceVariables _ nilOrArray.
    classPool _ pool.
    sharedPools _ poolSet! !

!Class methodsFor: 'initialize-release'!
validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods
    "Recompile the receiver and redefine its subclasses if necessary."

    super
        validateFrom: oldClass
        in: environ
        instanceVariableNames: invalidFields
        methods: invalidMethods.
    self ~~ oldClass
        ifTrue:
            [environ at: name put: self.
            oldClass obsolete]! !


!Class methodsFor: 'accessing'!
classPool
    "Answer the dictionary of class variables."

    classPool == nil
        ifTrue: [^Dictionary new]
        ifFalse: [^classPool]! !

!Class methodsFor: 'accessing'!
name
    "Answer the name of the receiver."

    name == nil
        ifTrue: [^super name]
        ifFalse: [^name]! !


!Class methodsFor: 'testing'!
hasMethods
    "Answer a Boolean according to whether any methods are defined for the
    receiver (includes whether there are methods defined in the receiver's
    metaclass)."

    ^super hasMethods or: [self class hasMethods]! !


!Class methodsFor: 'copying'!
copy
    | newClass |
    newClass _ self class copy new
        superclass: superclass
        methodDict: methodDict copy
        format: format
        name: name
        organization: organization copy
        instVarNames: instanceVariables copy
        classPool: classPool copy
        sharedPools: sharedPools.
    Class instSize+1 to: self class instSize do:
        [:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
    ^ newClass! !

!Class methodsFor: 'copying'!
copyForValidation
    "Make a copy of the receiver (a class) but do not install the created class
    as a new class in the system. This is used for creating a new version of
    the receiver in which the installation is deferred until all changes are
    successfully completed."
    | newClass |
    newClass _ self class copy new
        superclass: superclass
        methodDict: methodDict copy
        format: format
        name: name
        organization: organization
        instVarNames: instanceVariables copy
        classPool: classPool
        sharedPools: sharedPools.
    Class instSize+1 to: self class instSize do:
        [:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
    ^ newClass! !

!Class methodsFor: 'copying' stamp: 'sw 6/12/96'!
copyOfMethodDictionary
    "Return a copy of the receiver's method dictionary.  "

    ^ methodDict copy! !


!Class methodsFor: 'class name' stamp: 'tk 3/10/98 08:15'!
rename: aString
    "The new name of the receiver is the argument, aString."

    | newName |
    newName _ aString asSymbol.
    (Smalltalk includesKey: newName)
        ifTrue: [^self error: newName , ' already exists'].
    (Undeclared includesKey: newName)
        ifTrue: [^ SelectionMenu notify: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
    Smalltalk renameClass: self as: newName.
    name _ newName.
    self comment: self comment.
! !


!Class methodsFor: 'instance variables'!
addInstVarName: aString
    "Add the argument, aString, as one of the receiver's instance variables."

    superclass class
        name: self name
        inEnvironment: Smalltalk
        subclassOf: superclass
        instanceVariableNames: self instanceVariablesString , aString
        variable: self isVariable
        words: self isWords
        pointers: self isPointers
        classVariableNames: self classVariablesString
        poolDictionaries: self sharedPoolsString
        category: self category
        comment: nil
        changed: false! !

!Class methodsFor: 'instance variables'!
removeInstVarName: aString
    "Remove the argument, aString, as one of the receiver's instance variables."

    | newInstVarString |
    (self instVarNames includes: aString)
        ifFalse: [self error: aString , ' is not one of my instance variables'].
    newInstVarString _ ''.
    (self instVarNames copyWithout: aString) do:
        [:varName | newInstVarString _ newInstVarString , ' ' , varName].
    superclass class
        name: self name
        inEnvironment: Smalltalk
        subclassOf: superclass
        instanceVariableNames: newInstVarString
        variable: self isVariable
        words: self isWords
        pointers: self isPointers
        classVariableNames: self classVariablesString
        poolDictionaries: self sharedPoolsString
        category: self category
        comment: nil
        changed: false! !


!Class methodsFor: 'class variables'!
addClassVarName: aString
    "Add the argument, aString, as a class variable of the receiver.
    Signal an error if the first character of aString is not capitalized,
    or if it is already a variable named in the class."
    | symbol index |
    aString first isLowercase
        ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
    symbol _ aString asSymbol.
    self withAllSubclasses do:
        [:subclass |
        subclass scopeHas: symbol
            ifTrue: [:temp |
                    ^ self error: aString
                        , ' is already used as a variable name in class '
                        , subclass name]].
    classPool == nil ifTrue: [classPool _ Dictionary new].
    (classPool includesKey: symbol) ifFalse:
        ["Pick up any refs in Undeclared"
        classPool declare: symbol from: Undeclared.
        Smalltalk changes changeClass: self]! !

!Class methodsFor: 'class variables'!
allClassVarNames
    "Answer a Set of the names of the receiver's class variables, including those
    defined in the superclasses of the receiver."

    | aSet |
    superclass == nil
        ifTrue:
            [^self classVarNames]  "This is the keys so it is a new Set."
        ifFalse:
            [aSet _ superclass allClassVarNames.
            aSet addAll: self classVarNames.
            ^aSet]! !

!Class methodsFor: 'class variables'!
classVarNames
    "Answer a Set of the names of the class variables defined in the receiver."

    ^self classPool keys! !

!Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'!
ensureClassPool

    classPool ifNil: [classPool _ Dictionary new].! !

!Class methodsFor: 'class variables'!
initialize
    "Typically used for the initialization of class variables and metaclass
    instance variables. Does nothing, but may be overridden in Metaclasses."

    ^self! !

!Class methodsFor: 'class variables'!
removeClassVarName: aString
    "Remove the class variable whose name is the argument, aString, from
    the names defined in the receiver, a class. Create an error notification if
    aString is not a class variable or if it is still being used in the code of
    the class."

    | anAssoc aSymbol |
    aSymbol _ aString asSymbol.
    (classPool includesKey: aSymbol)
        ifFalse: [^self error: aString, ' is not a class variable'].
    anAssoc _ classPool associationAt: aSymbol.
    self withAllSubclasses do:
        [:subclass |
        (Array with: subclass with: subclass class) do:
            [:classOrMeta |
            (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol))
                isEmpty
                    ifFalse: [^self error: aString
                                , ' is still used in code of class '
                                , classOrMeta name]]].
    classPool removeKey: aSymbol! !


!Class methodsFor: 'pool variables'!
addSharedPool: aDictionary
    "Add the argument, aDictionary, as one of the receiver's pool dictionaries.
    Create an error if the dictionary is already one of the pools."

    (self sharedPools includes: aDictionary)
        ifTrue: [^self error: 'The dictionary is already in my pool'].
    sharedPools == nil
        ifTrue: [sharedPools _ OrderedCollection with: aDictionary]
        ifFalse: [sharedPools add: aDictionary]! !

!Class methodsFor: 'pool variables'!
allSharedPools
    "Answer a Set of the pools the receiver shares, including those defined
    in the superclasses of the receiver."

    | aSet |
    superclass == nil
        ifTrue:
            [^self sharedPools copy]
        ifFalse:
            [aSet _ superclass allSharedPools.
            aSet addAll: self sharedPools.
            ^aSet]! !

!Class methodsFor: 'pool variables' stamp: 'tk 9/12/96'!
removeSharedPool: aDictionary
    "Remove the pool dictionary, aDictionary, as one of the receiver's pool
    dictionaries. Create an error notification if the dictionary is not one of
    the pools.
    : Note that it removes the wrong one if there are two empty Dictionaries in the list."

    | satisfiedSet workingSet aSubclass |
    (self sharedPools includes: aDictionary)
        ifFalse: [^self error: 'the dictionary is not in my pool'].

    "first see if it is declared in a superclass in which case we can remove it."
    (self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty
        ifFalse: [sharedPools remove: aDictionary.
                sharedPools isEmpty ifTrue: [sharedPools _ nil].
                ^self].

    "second get all the subclasses that reference aDictionary through me rather than a
    superclass that is one of my subclasses."

    workingSet _ self subclasses asOrderedCollection.
    satisfiedSet _ Set new.
    [workingSet isEmpty] whileFalse:
        [aSubclass _ workingSet removeFirst.
        (aSubclass sharedPools includes: aDictionary)
            ifFalse:
                [satisfiedSet add: aSubclass.
                workingSet addAll: aSubclass subclasses]].

    "for each of these, see if they refer to any of the variables in aDictionary because
    if they do, we can not remove the dictionary."
    satisfiedSet add: self.
    satisfiedSet do:
        [:sub |
        aDictionary associationsDo:
            [:aGlobal |
            (sub whichSelectorsReferTo: aGlobal) isEmpty
                ifFalse: [^self error: aGlobal key
                                , ' is still used in code of class '
                                , sub name]]].
    sharedPools remove: aDictionary.
    sharedPools isEmpty ifTrue: [sharedPools _ nil]! !

!Class methodsFor: 'pool variables'!
sharedPools
    "Answer a Set of the pool dictionaries declared in the receiver."

    sharedPools == nil
        ifTrue: [^OrderedCollection new]
        ifFalse: [^sharedPools]! !


!Class methodsFor: 'compiling'!
compileAllFrom: oldClass
    "Recompile all the methods in the receiver's method dictionary (not the
    subclasses). Also recompile the methods in the metaclass."

    super compileAllFrom: oldClass.
    self class compileAllFrom: oldClass class! !

!Class methodsFor: 'compiling'!
possibleVariablesFor: misspelled continuedFrom: oldResults

    | results |
    results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
    self sharedPools do: [:pool |
        results _ misspelled correctAgainstDictionary: pool continuedFrom: results ].
    superclass == nil
        ifTrue:
            [ ^ misspelled correctAgainstDictionary: Smalltalk continuedFrom: results ]
        ifFalse:
            [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! !

!Class methodsFor: 'compiling' stamp: 'tk 9/11/96'!
scopeHas: varName ifTrue: assocBlock
    "Look up the first argument, varName, in the context of the receiver. If it is there,
    pass the association to the second argument, assocBlock, and answer true.
    Else answer false.
    : Allow key in shared pools to be a string for HyperSqueak"

    | assoc |
    assoc _ self classPool associationAt: varName ifAbsent: [].
    assoc == nil
        ifFalse:
            [assocBlock value: assoc.
            ^true].
    self sharedPools do:
        [:pool |
        varName = #Textual ifTrue: [self halt].
        assoc _ pool associationAt: varName ifAbsent: [
            pool associationAt: varName asString ifAbsent: []].
        assoc == nil
            ifFalse:
                [assocBlock value: assoc.
                ^true]].
    superclass == nil
        ifTrue:
            [assoc _ Smalltalk associationAt: varName ifAbsent: [].
            assoc == nil
                ifFalse:
                    [assocBlock value: assoc.
                    ^true].
            ^false].
    ^superclass scopeHas: varName ifTrue: assocBlock! !


!Class methodsFor: 'subclass creation' stamp: 'sw 5/19/1998 09:07'!
newSubclass
    | i className |
    i _ 1.
    [className _ (self name , i printString) asSymbol.
     Smalltalk includesKey: className]
        whileTrue: [i _ i + 1].

    ^ self subclass: className
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        category: 'UserObjects'

"Point newSubclass new"! !

!Class methodsFor: 'subclass creation'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
    "This is the standard initialization message for creating a new class as a
    subclass of an existing class (the receiver)."

    self isVariable
        ifTrue:
            [self isPointers
                ifTrue: [^self
                            variableSubclass: t
                            instanceVariableNames: f
                            classVariableNames: d
                            poolDictionaries: s
                            category: cat].
            self isBytes
                ifTrue: [^self
                            variableByteSubclass: t
                            instanceVariableNames: f
                            classVariableNames: d
                            poolDictionaries: s
                            category: cat].
            ^self
                variableWordSubclass: t
                instanceVariableNames: f
                classVariableNames: d
                poolDictionaries: s
                category: cat].
    ^self class
        name: t
        inEnvironment: Smalltalk
        subclassOf: self
        instanceVariableNames: f
        variable: false
        words: true
        pointers: true
        classVariableNames: d
        poolDictionaries: s
        category: cat
        comment: nil
        changed: false! !

!Class methodsFor: 'subclass creation'!
variableByteSubclass: t instanceVariableNames: f
    classVariableNames: d poolDictionaries: s category: cat
    "This is the standard initialization message for creating a new class as a
    subclass of an existing class (the receiver) in which the subclass is to
    have indexable byte-sized nonpointer variables."

    self instSize > 0
        ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
    (self isVariable and: [self isWords])
        ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
    (self isVariable and: [self isPointers])
        ifTrue: [^self error:
                    'cannot make a byte subclass of a class with pointer fields'].
    ^self class name: t
        inEnvironment: Smalltalk
        subclassOf: self
        instanceVariableNames: f
        variable: true
        words: false
        pointers: false
        classVariableNames: d
        poolDictionaries: s
        category: cat
        comment: nil
        changed: false! !

!Class methodsFor: 'subclass creation'!
variableSubclass: t instanceVariableNames: f
    classVariableNames: d poolDictionaries: s category: cat
    "This is the standard initialization message for creating a new class as a
    subclass of an existing class (the receiver) in which the subclass is to
    have indexable pointer variables."

    self isBits
        ifTrue:
            [^self error:
                'cannot make a pointer subclass of a class with non-pointer fields'].
    ^self class name: t
        inEnvironment: Smalltalk
        subclassOf: self
        instanceVariableNames: f
        variable: true
        words: true
        pointers: true
        classVariableNames: d
        poolDictionaries: s
        category: cat
        comment: nil
        changed: false! !

!Class methodsFor: 'subclass creation'!
variableWordSubclass: t instanceVariableNames: f
    classVariableNames: d poolDictionaries: s category: cat
    "This is the standard initialization message for creating a new class as a
    subclass of an existing class (the receiver) in which the subclass is to
    have indexable word-sized nonpointer variables."

    self instSize > 0
        ifTrue: [^self error:
                    'cannot make a word subclass of a class with named fields'].
    self isBytes
        ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
    (self isVariable and: [self isPointers])
        ifTrue: [^self error:
                    'cannot make a word subclass of a class with pointer fields'].
    ^self class name: t
        inEnvironment: Smalltalk
        subclassOf: self
        instanceVariableNames: f
        variable: true
        words: true
        pointers: false
        classVariableNames: d
        poolDictionaries: s
        category: cat
        comment: nil
        changed: false! !


!Class methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 09:58'!
fileOut
    "Create a file whose name is the name of the receiver with '.st' as the
    extension, and file a description of the receiver onto it."
    ^ self fileOutAsHtml: false! !

!Class methodsFor: 'fileIn/Out' stamp: 'jm 3/27/98 08:31'!
fileOutAsHtml: useHtml
    "File a description of the receiver onto a new file whose base name is the name of the receiver."

    | fileStream |
    fileStream _ useHtml
        ifTrue: [(FileStream newFileNamed: self name, FileDirectory dot, 'html') asHtml]
        ifFalse: [FileStream newFileNamed: self name, FileDirectory dot, 'st'].
    fileStream header; timeStamp.
    self sharedPools size > 0 ifTrue: [
        self shouldFileOutPools
            ifTrue: [self fileOutSharedPoolsOn: fileStream]].
    self fileOutOn: fileStream moveSource: false toFile: 0.
    fileStream trailer; close.
! !

!Class methodsFor: 'fileIn/Out'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
    "File a description of the receiver on aFileStream. If the boolean argument,
    moveSource, is true, then set the trailing bytes to the position of aFileStream and
    to fileIndex in order to indicate where to find the source code."

    Transcript cr; show: name.
    super
        fileOutOn: aFileStream
        moveSource: moveSource
        toFile: fileIndex.
    self class nonTrivial
        ifTrue:
            [aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
            self class
                fileOutOn: aFileStream
                moveSource: moveSource
                toFile: fileIndex]! !

!Class methodsFor: 'fileIn/Out' stamp: 'ikp 1/3/98 22:45'!
fileOutPool: aPool onFileStream: aFileStream
    | aPoolName aValue |
    aPoolName _ Smalltalk keyAtValue: aPool.
    Transcript cr; show: aPoolName.
    aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr.
    aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr.
    aPool keys asSortedCollection do: [ :aKey |
        aValue _ aPool at: aKey.
        aFileStream nextPutAll: aPoolName , ' at: #' , aKey asString , ' put:  '.
        (aValue isKindOf: Number)
            ifTrue: [aValue printOn: aFileStream]
            ifFalse: [aFileStream nextPutAll: '('.
                    aValue printOn: aFileStream.
                    aFileStream nextPutAll: ')'].
        aFileStream nextPutAll: '!!'; cr].
    aFileStream cr! !

!Class methodsFor: 'fileIn/Out'!
fileOutSharedPoolsOn: aFileStream
    "file out the shared pools of this class after prompting the user about each pool"
    | poolsToFileOut |
    poolsToFileOut _ self sharedPools select:
        [:aPool | (self shouldFileOutPool: (Smalltalk keyAtValue: aPool))].
    poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream].
    ! !

!Class methodsFor: 'fileIn/Out' stamp: 'tk 3/24/98 10:16'!
objectToStoreOnDataStream
    "I am about to be written on an object file.  Write a reference to a class in Smalltalk instead."

    ^ DiskProxy global: self theNonMetaClass name selector: #yourself
            args: (Array new)! !

!Class methodsFor: 'fileIn/Out'!
reformatAll
    "Reformat all methods in this class.
    Leaves old code accessible to version browsing"
    super reformatAll.        "me..."
    self class reformatAll    "...and my metaclass"! !

!Class methodsFor: 'fileIn/Out'!
removeFromChanges
    "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet.
    7/18/96 sw: call removeClassAndMetaClassChanges:"

    Smalltalk changes removeClassAndMetaClassChanges: self! !

!Class methodsFor: 'fileIn/Out'!
shouldFileOutPool: aPoolName
    "respond with true if the user wants to file out aPoolName"
    ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! !

!Class methodsFor: 'fileIn/Out'!
shouldFileOutPools
    "respond with true if the user wants to file out the shared pools"
    ^self confirm: 'FileOut selected sharedPools?'! !

!Class methodsFor: 'fileIn/Out' stamp: 'tk 3/26/98 10:18'!
storeDataOn: aDataStream
    "I don't get stored.  Use a DiskProxy"

    self error: 'use a DiskProxy to store a Class'! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Class class
    instanceVariableNames: ''!

!Class class methodsFor: 'instance creation'!
template: category
    "Answer an expression that can be edited and evaluated in order to
    define a new class."

    ^'Object subclass: #NameOfClass
    instanceVariableNames: ''instVarName1 instVarName2''
    classVariableNames: ''ClassVarName1 ClassVarName2''
    poolDictionaries: ''''
    category: ''' , category , ''''! !


!Class class methodsFor: 'fileIn/Out'!
fileOutPool: aString
    "file out the global pool named aString"
    | f |
    f _ FileStream newFileNamed: aString, '.st'.
    self new fileOutPool: (Smalltalk at: aString asSymbol) onFileStream: f.     f close.
    ! !
Object subclass: #ClassCategoryReader
    instanceVariableNames: 'class category changeStamp '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Classes'!
!ClassCategoryReader commentStamp: 'di 5/22/1998 16:32' prior: 0!
ClassCategoryReader comment:
'I represent a mechanism for retrieving class descriptions stored on a file.'!


!ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 12/15/97 16:26'!
scanFrom: aStream
    "File in methods from the stream, aStream."
    | methodText |
    [methodText _ aStream nextChunkText.
     methodText size > 0]
        whileTrue:
        [class compile: methodText classified: category
            withStamp: changeStamp
            notifying: (SyntaxError new category: category)]! !


!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory
    ^ self setClass: aClass category: aCategory changeStamp: String new
! !

!ClassCategoryReader methodsFor: 'private' stamp: '6/5/97 di'!
setClass: aClass category: aCategory changeStamp: aString

    class _ aClass.
    category _ aCategory.
    changeStamp _ aString
! !
ClassCategoryReader subclass: #ClassCommentReader
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Classes'!

!ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 12/15/97 15:56'!
scanFrom: aStream
    "File in the class comment from aStream.  Not string-i-fied, just a text, exactly as it is in the browser.  Move to changes file."

    class theNonMetaClass classComment: (aStream nextChunkText).
        "Writes it on the disk and saves a RemoteString ref"! !
Behavior subclass: #ClassDescription
    instanceVariableNames: 'instanceVariables organization '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Classes'!
!ClassDescription commentStamp: 'di 5/22/1998 16:32' prior: 0!
ClassDescription comment:
'I add a number of facilities to basic Behavior:
    Named instance variables
    Category organization for methods
    The notion of a name of this class (implemented as subclass responsibility)
    The maintenance of a ChangeSet, and logging changes on a file
    Most of the mechanism for fileOut.

I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.'!


!ClassDescription methodsFor: 'initialize-release'!
obsolete
    "Make the receiver obsolete."

    organization _ nil.
    super obsolete! !

!ClassDescription methodsFor: 'initialize-release' stamp: 'tk 3/19/98 10:18'!
subclassOf: newSuper oldClass: oldClass instanceVariableNames: newInstVarString variable: v words: w pointers: p ifBad: badBlock
    "Basic initialization message for creating classes using the information
    provided as arguments. Answer whether old instances will be
    invalidated."
    | oldNames newNames usedNames invalid oldSuperMeta newInstVarArray oldSpec |
    oldNames _ self allInstVarNames.
    usedNames _ #(self super thisContext true false nil ) asSet.
    newInstVarArray _ Scanner new scanFieldNames: newInstVarString.
    newNames _ newSuper allInstVarNames , newInstVarArray.
    newNames size > 254 ifTrue:
        [self error: 'A class cannot have more than 254 instance variables'.
        ^ badBlock value].
    newNames do:
        [:fieldName |
        (usedNames includes: fieldName)
            ifTrue:
                [self error: fieldName , ' is reserved (maybe in a superclass)'.
                ^ badBlock value].
        usedNames add: fieldName].
    (invalid _ superclass ~~ newSuper)
        ifTrue:
            ["superclass changed"
            oldSuperMeta _ superclass class.
            superclass ifNotNil: [superclass removeSubclass: self.
                "Object flushCache"        "done in removeSubclass"].
            superclass _ newSuper.
            superclass addSubclass: self.
            self class superclass == oldSuperMeta
                ifTrue: ["Only false when self is a metaclass"
                        self class superclass: newSuper class]].
    instanceVariables _ newInstVarArray size = 0 ifFalse: [newInstVarArray].
    invalid _ invalid | (newNames  ~= oldNames).   "field names changed"
    oldSpec _ self instSpec.
    self format: newNames size
        variable: v
        words: w
        pointers: p.
    invalid _ invalid | (self instSpec ~= oldSpec).  "format changed"
    ^invalid! !

!ClassDescription methodsFor: 'initialize-release'!
updateInstancesFrom: oldClass
    "Recreate any existing instances of the argument, oldClass, as instances of
    the receiver, which is a newly changed class. Permute variables as
    necessary."

    | oldInstVarNames map variable new instSize oldInstances |
    oldClass someInstance == nil ifTrue: [^self].
    "no instances to convert"
    oldInstVarNames _ oldClass allInstVarNames.
    map _
        self allInstVarNames
            collect: [:instVarName | oldInstVarNames indexOf: instVarName].
    variable _ self isVariable.
    instSize _ self instSize.

    "Now perform a bulk mutation of old instances into new ones"
    oldInstances _ oldClass allInstances asArray.
    oldInstances elementsExchangeIdentityWith:
        (oldInstances collect:
        [:old |
        variable
            ifTrue: [new _ self basicNew: old basicSize]
            ifFalse: [new _ self basicNew].
        1 to: instSize do:
            [:offset |  (map at: offset) > 0 ifTrue:
                [new instVarAt: offset
                        put: (old instVarAt: (map at: offset))]].
        variable
            ifTrue: [1 to: old basicSize do:
                        [:offset |
                        new basicAt: offset put: (old basicAt: offset)]].
        new])! !

!ClassDescription methodsFor: 'initialize-release'!
validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods
    "Recompile the receiver, a class, and redefine its subclasses if necessary.
    The parameter invalidFields is no longer really used"

    | newSub invalidSubMethods |
    oldClass becomeUncompact.  "Its about to be abandoned"
    invalidMethods & self hasMethods
        ifTrue:
            [Transcript show: 'recompiling ' , self name , '...'.
            self compileAllFrom: oldClass.
            Transcript show: ' done'; cr].
    invalidSubMethods _ invalidMethods | (self instSize ~= oldClass instSize).
    self == oldClass
        ifTrue: [invalidSubMethods ifFalse: [^self]]
        ifFalse: [self updateInstancesFrom: oldClass].
    oldClass subclasses do:
        [:sub |
        newSub _ sub copyForValidation.
        newSub
            subclassOf: self
            oldClass: sub
            instanceVariableNames: sub instVarNames
            variable: sub isVariable
            words: sub isBytes not
            pointers: sub isBits not
            ifBad: [self error: 'terrible problem in recompiling subclasses!!'].
        newSub
            validateFrom: sub
            in: environ
            instanceVariableNames: invalidFields
            methods: invalidSubMethods]! !


!ClassDescription methodsFor: 'accessing'!
classVersion
    "Default.  Any class may return a later version to inform readers that use ReferenceStream.  8/17/96 tk"
    ^ 0! !

!ClassDescription methodsFor: 'accessing' stamp: 'tk 12/13/97 14:33'!
comment
    "Answer the receiver's comment. (If old format, not a Text, unpack the old way.) "

    | aString |
    aString _ self theNonMetaClass organization classComment.
    (aString asString beginsWith: self name, ' comment:\''' withCRs)
        ifFalse: [^ self theNonMetaClass organization classComment]
        ifTrue: ["old format"
            aString size = 0 ifTrue: [^''].
            "get string only of classComment, undoubling quotes"
            ^ String readFromString: aString]! !

!ClassDescription methodsFor: 'accessing' stamp: 'tk 12/16/97 07:49'!
comment: aStringOrText
    "Set the receiver's comment to be the argument, aStringOrText."

    self theNonMetaClass classComment: aStringOrText.
    Smalltalk changes commentClass: self! !

!ClassDescription methodsFor: 'accessing'!
isMeta
    ^ false! !

!ClassDescription methodsFor: 'accessing'!
name
    "Answer a String that is the name of the receiver."

    self subclassResponsibility! !

!ClassDescription methodsFor: 'accessing'!
theNonMetaClass
    "Sent to a class or metaclass, always return the class"

    ^self! !


!ClassDescription methodsFor: 'copying'!
copy: sel from: class
    "Install the method associated with the first argument, sel, a message
    selector, found in the method dictionary of the second argument, class,
    as one of the receiver's methods. Classify the message under -As yet not
    classified-."

    self copy: sel
        from: class
        classified: nil! !

!ClassDescription methodsFor: 'copying'!
copy: sel from: class classified: cat
    "Install the method associated with the first arugment, sel, a message
    selector, found in the method dictionary of the second argument, class,
    as one of the receiver's methods. Classify the message under the third
    argument, cat."

    | code category |
    "Useful when modifying an existing class"
    code _ class sourceMethodAt: sel.
    code == nil
        ifFalse:
            [cat == nil
                ifTrue: [category _ class organization categoryOfElement: sel]
                ifFalse: [category _ cat].
            (methodDict includesKey: sel)
                ifTrue: [code asString = (self sourceMethodAt: sel) asString
                            ifFalse: [self error: self name
                                        , ' '
                                        , sel
                                        , ' will be redefined if you proceed.']].
            self compile: code classified: category]! !

!ClassDescription methodsFor: 'copying'!
copyAll: selArray from: class
    "Install all the methods found in the method dictionary of the second
    argument, class, as the receiver's methods. Classify the messages under
    -As yet not classified-."

    self copyAll: selArray
        from: class
        classified: nil! !

!ClassDescription methodsFor: 'copying'!
copyAll: selArray from: class classified: cat
    "Install all the methods found in the method dictionary of the second
    argument, class, as the receiver's methods. Classify the messages under
    the third argument, cat."

    selArray do:
        [:s | self copy: s
                from: class
                classified: cat]! !

!ClassDescription methodsFor: 'copying'!
copyAllCategoriesFrom: aClass
    "Specify that the categories of messages for the receiver include all of
    those found in the class, aClass. Install each of the messages found in
    these categories into the method dictionary of the receiver, classified
    under the appropriate categories."

    aClass organization categories do: [:cat | self copyCategory: cat from: aClass]! !

!ClassDescription methodsFor: 'copying'!
copyCategory: cat from: class
    "Specify that one of the categories of messages for the receiver is cat, as
    found in the class, class. Copy each message found in this category."

    self copyCategory: cat
        from: class
        classified: cat! !

!ClassDescription methodsFor: 'copying'!
copyCategory: cat from: aClass classified: newCat
    "Specify that one of the categories of messages for the receiver is the
    third argument, newCat. Copy each message found in the category cat in
    class aClass into this new category."

    self copyAll: (aClass organization listAtCategoryNamed: cat)
        from: aClass
        classified: newCat! !


!ClassDescription methodsFor: 'printing'!
classVariablesString
    "Answer a string of my class variable names separated by spaces."
    | aStream |
    aStream _ WriteStream on: (String new: 100).
    self classPool keys asSortedCollection do: [:key | aStream nextPutAll: key; space].
    ^aStream contents! !

!ClassDescription methodsFor: 'printing'!
instanceVariablesString
    "Answer a string of my instance variable names separated by spaces."

    | aStream names |
    aStream _ WriteStream on: (String new: 100).
    names _ self instVarNames.
    1 to: names size do: [:i | aStream nextPutAll: (names at: i); space].
    ^aStream contents! !

!ClassDescription methodsFor: 'printing'!
printOn: aStream

    aStream nextPutAll: self name! !

!ClassDescription methodsFor: 'printing'!
sharedPoolsString
    "Answer a string of my shared pool names separated by spaces."

    | aStream |
    aStream _ WriteStream on: (String new: 100).
    self sharedPools do: [:x | aStream nextPutAll: (Smalltalk keyAtValue: x ifAbsent: ['private']); space].
    ^ aStream contents! !

!ClassDescription methodsFor: 'printing'!
storeOn: aStream
    "Classes and Metaclasses have global names."

    aStream nextPutAll: self name! !


!ClassDescription methodsFor: 'instance variables'!
addInstVarName: aString
    "Add the argument, aString, as one of the receiver's instance variables."

    self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables'!
browseClassVariables
    "Put up a browser showing the receiver's class variables.  2/1/96 sw"

    self classPool inspectWithLabel: 'Class Variables in ', self name! !

!ClassDescription methodsFor: 'instance variables'!
browseClassVarRefs
    "1/17/96 sw: moved here from Browser so that it could be used from a variety of places."

    | lines labelStream vars allVars index owningClasses |

    lines _ OrderedCollection new.
    allVars _ OrderedCollection new.
    owningClasses _ OrderedCollection new.
    labelStream _ WriteStream on: (String new: 200).
    self withAllSuperclasses reverseDo:
        [:class |
        vars _ class classVarNames asSortedCollection.
        vars do:
            [:var |
            labelStream nextPutAll: var; cr.
            allVars add: var.
            owningClasses add: class].
        vars isEmpty ifFalse: [lines add: allVars size]].
    labelStream skip: -1 "cut last CR".
    index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
    index = 0 ifTrue: [^ self].
    Smalltalk browseAllCallsOn:
        ((owningClasses at: index) classPool associationAt: (allVars at: index))! !

!ClassDescription methodsFor: 'instance variables'!
browseInstVarDefs
    "Copied from browseInstVarRefs.  Should be consolidated some day. 7/29/96 di
    7/30/96 sw: did the consolidation"

    self chooseInstVarThenDo:
        [:aVar | self browseAllStoresInto: aVar]! !

!ClassDescription methodsFor: 'instance variables'!
browseInstVarRefs
    "1/16/96 sw: moved here from Browser so that it could be used from a variety of places.
     7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice"

    self chooseInstVarThenDo:
        [:aVar | self browseAllAccessesTo: aVar]! !

!ClassDescription methodsFor: 'instance variables' stamp: 'sw 7/29/97 18:34'!
chooseInstVarThenDo: aBlock
    "Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter.  7/30/96 sw"

    | lines labelStream vars allVars index |

    lines _ OrderedCollection new.
    allVars _ OrderedCollection new.
    labelStream _ WriteStream on: (String new: 200).
    self withAllSuperclasses reverseDo:
        [:class |
        vars _ class instVarNames.
        vars do:
            [:var |
            labelStream nextPutAll: var; cr.
            allVars add: var].
        vars isEmpty ifFalse: [lines add: allVars size]].
    labelStream isEmpty ifTrue:
        [^ (PopUpMenu labels: ' OK ')
            startUpWithCaption: 'There are no
instance variables.'].
    labelStream skip: -1 "cut last CR".
    index _ (PopUpMenu labels: labelStream contents lines: lines) startUpWithCaption: 'Instance variables in
', class name.
    index = 0 ifTrue: [^ self].
    aBlock value: (allVars at: index)! !

!ClassDescription methodsFor: 'instance variables'!
forceNewFrom: anArray
    "Create a new instance of the class and fill
    its instance variables up with the array."
    | object max |

    object _ self new.
    max _ self instSize.
    anArray doWithIndex: [:each :index |
        index > max ifFalse:
            [object instVarAt: index put: each]].
    ^ object! !

!ClassDescription methodsFor: 'instance variables'!
instVarNames
    "Answer an Array of the receiver's instance variable names."

    instanceVariables == nil
        ifTrue: [^#()]
        ifFalse: [^instanceVariables]! !

!ClassDescription methodsFor: 'instance variables'!
removeInstVarName: aString
    "Remove the argument, aString, as one of the receiver's instance
    variables. Create an error notification if the argument is not found."

    self subclassResponsibility! !

!ClassDescription methodsFor: 'instance variables' stamp: 'di 7/15/97 00:04'!
renameInstVar: oldName to: newName
    | i oldCode newCode parser header body sels |
    (i _ instanceVariables indexOf: oldName) = 0 ifTrue:
        [self error: oldName , ' is not defined in ', self name].
    self allSuperclasses , self withAllSubclasses asOrderedCollection do:
        [:cls | (cls instVarNames includes: newName) ifTrue:
            [self error: newName , ' is already used in ', cls name]].
    (self confirm: 'WARNING: Renaming of instance variables
is subject to substitution ambiguities.
Do you still wish to attempt it?') ifFalse: [self halt].

    "...In other words, this does a dumb text search-and-replace,
    which might improperly alter, eg, a literal string.  As long as
    the oldName is unique, everything should work jes' fine. - di"
    instanceVariables replaceFrom: i to: i with: (Array with: newName).
    self withAllSubclasses do:
        [:cls | sels _ cls selectors.
        sels removeAllFoundIn: #(DoIt DoItIn:).
        sels do:
            [:sel |
            oldCode _ cls sourceCodeAt: sel.
            "Don't make changes in the method header"
            (parser _ cls parserClass new) parseSelector: oldCode.
            header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size).
            body _ header size > oldCode size
                    ifTrue: ['']
                    ifFalse: [oldCode copyFrom: header size+1 to: oldCode size].
            newCode _ header , (body copyReplaceTokens: oldName with: newName).
            newCode ~= oldCode ifTrue:
                [cls compile: newCode
                    classified: (cls organization categoryOfElement: sel)
                    notifying: nil]].
            cls isMeta ifFalse:
                [oldCode _ cls comment.
                newCode _ oldCode copyReplaceTokens: oldName with: newName.
                newCode ~= oldCode ifTrue:
                    [cls comment: newCode]]]! !


!ClassDescription methodsFor: 'method dictionary'!
removeCategory: aString
    "Remove each of the messages categorized under aString in the method
    dictionary of the receiver. Then remove the category aString."
    | categoryName |
    categoryName _ aString asSymbol.
    (self organization listAtCategoryNamed: categoryName) do:
        [:sel | self removeSelector: sel].
    self organization removeCategory: categoryName! !

!ClassDescription methodsFor: 'method dictionary' stamp: 'sw 2/28/98 22:02'!
removeSelector: aSymbol
    "Remove the message whose selector is aSymbol from the method
    dictionary of the receiver, if it is there. Answer nil otherwise."

    (methodDict includesKey: aSymbol) ifFalse: [^nil].
    self wantsChangeSetLogging ifTrue:
        [Smalltalk changes removeSelector: aSymbol class: self].
    super removeSelector: aSymbol.
    self organization removeElement: aSymbol.
    self acceptsLoggingOfCompilation ifTrue:
        [Smalltalk logChange: self name , ' removeSelector: #' , aSymbol]! !


!ClassDescription methodsFor: 'organization'!
category
    "Answer the system organization category for the receiver."

    ^SystemOrganization categoryOfElement: self name! !

!ClassDescription methodsFor: 'organization'!
category: cat
    "Categorize the receiver under the system category, cat, removing it from
    any previous categorization."

    (cat isKindOf: String)
        ifTrue: [SystemOrganization classify: self name under: cat asSymbol]
        ifFalse: [self errorCategoryName]! !

!ClassDescription methodsFor: 'organization'!
organization
    "Answer the instance of ClassOrganizer that represents the organization
    of the messages of the receiver."

    organization==nil
        ifTrue: [organization _
                 ClassOrganizer defaultList:
                        methodDict keys asSortedCollection asArray].
    ^organization! !

!ClassDescription methodsFor: 'organization' stamp: 'di 7/17/97 00:06'!
whichCategoryIncludesSelector: aSelector
    "Answer the category of the argument, aSelector, in the organization of
    the receiver, or answer nil if the receiver does not inlcude this selector."

    (self includesSelector: aSelector)
        ifTrue: [^ self organization categoryOfElement: aSelector]
        ifFalse: [^nil]! !

!ClassDescription methodsFor: 'organization'!
zapOrganization
    "Remove the organization of this class by message categories.
    This is typically done to save space in small systems.  Classes and methods
    created or filed in subsequently will, nonetheless, be organized"

    organization _ nil.
    self isMeta ifFalse: [self class zapOrganization]! !


!ClassDescription methodsFor: 'compiling'!
acceptsLoggingOfCompilation
    "weird name is so that it will come lexically before #compile, so that a clean build can make it through.  7/7/96 sw"

    ^ true! !

!ClassDescription methodsFor: 'compiling'!
compile: code classified: heading
    "Compile the argument, code, as source code in the context of the
    receiver and install the result in the receiver's method dictionary under
    the classification indicated by the second argument, heading. nil is to be
    notified if an error occurs. The argument code is either a string or an
    object that converts to a string or a PositionableStream on an object that
    converts to a string."

    ^self
        compile: code
        classified: heading
        notifying: (SyntaxError new category: heading)! !

!ClassDescription methodsFor: 'compiling' stamp: 'sw 8/21/97 00:26'!
compile: text classified: category notifying: requestor
    | stamp |
    stamp _ self acceptsLoggingOfCompilation ifTrue: [Utilities changeStamp] ifFalse: [nil].
    ^ self compile: text classified: category
        withStamp: stamp notifying: requestor

 ! !

!ClassDescription methodsFor: 'compiling' stamp: 'di 2/2/98 12:51'!
compile: text classified: category withStamp: changeStamp notifying: requestor
    | selector priorMethod method methodNode newText |
    method _ self
        compile: text asString
        notifying: requestor
        trailer: #(0 0 0 0)
        ifFail: [^nil]
        elseSetSelectorAndNode:
            [:sel :node | selector _ sel.
            priorMethod _ methodDict at: selector ifAbsent: [nil].
            methodNode _ node].
    self acceptsLoggingOfCompilation ifTrue:
        [newText _ (requestor ~~ nil and: [Preferences confirmFirstUseOfStyle])
            ifTrue: [text askIfAddStyle: priorMethod req: requestor]
            ifFalse: [text].
         method putSource: newText
                fromParseNode: methodNode
                class: self category: category withStamp: changeStamp
                inFile: 2 priorMethod: priorMethod].
    self organization classify: selector under: category.
    ^selector! !

!ClassDescription methodsFor: 'compiling'!
compile: code notifying: requestor
    "Refer to the comment in Behavior|compile:notifying:."

    ^self compile: code
         classified: ClassOrganizer default
         notifying: requestor! !

!ClassDescription methodsFor: 'compiling'!
compile: code notifying: requestor trailer: bytes
        ifFail: failBlock
        elseSetSelectorAndNode: selAndNodeBlock
    "Intercept this message in order to remember system changes.
     5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set.
    7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set"

    | methodNode selector method |
    methodNode _ self compilerClass new
                compile: code
                in: self
                notifying: requestor
                ifFail: failBlock.
    selector _ methodNode selector.
    selAndNodeBlock value: selector value: methodNode.
    self wantsChangeSetLogging ifTrue:
        [(methodDict includesKey: selector)
            ifTrue: [Smalltalk changes changeSelector: selector class: self]
            ifFalse: [Smalltalk changes addSelector: selector class: self]].
    methodNode encoder requestor: requestor.  "Why was this not preserved?"
    method _ methodNode generate: bytes.
    self addSelector: selector withMethod: method.
    ^ method! !

!ClassDescription methodsFor: 'compiling'!
wantsChangeSetLogging
    "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.  7/12/96 sw"


    ^ true! !


!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 13:11'!
classComment: aString
    "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing.  Empty string gets stored only if had a non-empty one before."

    | ptr header file oldCommentRemoteStr |
    (aString isKindOf: RemoteString) ifTrue: [^ organization classComment: aString].
    oldCommentRemoteStr _ organization commentRemoteStr.
    (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ organization classComment: nil].
        "never had a class comment, no need to write empty string out"

    ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer].
    SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [
        file setToEnd; cr; nextPut: $!!.    "directly"
        "Should be saying (file command: 'H3') for HTML, but ignoring it here"
        header _ String streamContents: [:strm | strm nextPutAll: self name;
            nextPutAll: ' commentStamp: '.
            Utilities changeStamp storeOn: strm.
            strm nextPutAll: ' prior: '; nextPutAll: ptr printString].
        file nextChunkPut: header]].
    organization classComment: (RemoteString newString: aString onFileNumber: 2).
    Smalltalk changes commentClass: self.    ! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:20'!
commentFollows
    "Answer a ClassCommentReader who will scan in the comment."

    ^ ClassCommentReader new setClass: self category: #Comment

    "False commentFollows inspect"! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/13/97 14:21'!
commentStamp: changeStamp prior: indexAndOffset
    "Prior source link ignored when filing in."

    ^ ClassCommentReader new setClass: self
                category: #Comment
                changeStamp: changeStamp
! !

!ClassDescription methodsFor: 'fileIn/Out'!
definition
    "Answer a String that defines the receiver."

    | aStream |
    aStream _ WriteStream on: (String new: 300).
    aStream nextPutAll:
        (superclass == nil
            ifTrue: ['nil']
            ifFalse: [superclass name])
        , self kindOfSubclass.
    self name storeOn: aStream.
    aStream cr; tab; nextPutAll: 'instanceVariableNames: '.
    aStream store: self instanceVariablesString.
    aStream cr; tab; nextPutAll: 'classVariableNames: '.
    aStream store: self classVariablesString.
    aStream cr; tab; nextPutAll: 'poolDictionaries: '.
    aStream store: self sharedPoolsString.
    aStream cr; tab; nextPutAll: 'category: '.
    (SystemOrganization categoryOfElement: self name) asString storeOn: aStream.
    ^aStream contents! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:06'!
fileOutCategory: catName
    ^ self fileOutCategory: catName asHtml: false! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 10:05'!
fileOutCategory: catName asHtml: useHtml
    "FileOut the named category, possibly in Html format."
    | fileStream |
    fileStream _ useHtml
        ifTrue: [(FileStream newFileNamed: self name , '-' , catName , '.html') asHtml]
        ifFalse: [FileStream newFileNamed: self name , '-' , catName , '.st'].
    fileStream header; timeStamp.
    self fileOutCategory: catName on: fileStream moveSource: false toFile: 0.
    fileStream trailer; close! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 5/17/1998 10:40'!
fileOutCategory: aString on: aFileStream moveSource: moveSource toFile: fileIndex
    "File a description of the receiver's category, aString, onto aFileStream. If
    moveSource, is true, then set the method source pointer to the new file position.
    Note when this method is called with moveSource=true, it is condensing the
    .sources file, and should only write one preamble per method category."

    aFileStream cr.

true ifTrue:
    ["Overridden to preserve author stamps in sources file regardless"
    (self organization listAtCategoryNamed: aString)
        do: [:sel | self printMethodChunk: sel withPreamble: true
                        on: aFileStream moveSource: moveSource toFile: fileIndex].
    ^ self].

    moveSource ifTrue:
        ["Single header for condensing source files"
        self printCategoryChunk: aString on: aFileStream].
    (self organization listAtCategoryNamed: aString)
        do: [:sel | self printMethodChunk: sel withPreamble: moveSource not
                        on: aFileStream moveSource: moveSource toFile: fileIndex].
    moveSource ifTrue: [aFileStream nextChunkPut: ' ']! !

!ClassDescription methodsFor: 'fileIn/Out'!
fileOutChangedMessages: aSet on: aFileStream
    "File a description of the messages of the receiver that have been
    changed (i.e., are entered into the argument, aSet) onto aFileStream."

    self fileOutChangedMessages: aSet
        on: aFileStream
        moveSource: false
        toFile: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/26/97 21:41'!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex
    "File a description of the messages of this class that have been
    changed (i.e., are entered into the argument, aSet) onto aFileStream.  If
    moveSource, is true, then set the method source pointer to the new file position.
    Note when this method is called with moveSource=true, it is condensing the
    .changes file, and should only write a preamble for every method."
    | org sels |
    (org _ self organization) categories do:
        [:cat |
        sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
        sels do:
            [:sel |  self printMethodChunk: sel withPreamble: true on: aFileStream
                            moveSource: moveSource toFile: fileIndex]]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:52'!
fileOutMethod: selector
    "Write source code of a single method on a file.  Make up a name for the file."
    self fileOutMethod: selector asHtml: false! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 15:51'!
fileOutMethod: selector asHtml: useHtml
    "Write source code of a single method on a file in .st or .html format"
    | fileStream nameBody |
    (self includesSelector: selector) ifFalse: [^ self halt: 'Selector not found'].
    nameBody _ self name , '-' , (selector copyReplaceAll: ':' with: '').
    fileStream _ useHtml
        ifTrue: [(FileStream newFileNamed: nameBody , '.html') asHtml]
        ifFalse: [FileStream newFileNamed: nameBody , '.st'].
    fileStream header; timeStamp.
    self printMethodChunk: selector withPreamble: true
        on: fileStream moveSource: false toFile: 0.
    fileStream close! !

!ClassDescription methodsFor: 'fileIn/Out'!
fileOutOn: aFileStream
    "File a description of the receiver on aFileStream."

    self fileOutOn: aFileStream
        moveSource: false
        toFile: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/15/98 23:38'!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
    "File a description of the receiver on aFileStream. If the boolean
    argument, moveSource, is true, then set the trailing bytes to the position
    of aFileStream and to fileIndex in order to indicate where to find the
    source code."

    aFileStream command: 'H3'.
        aFileStream nextChunkPut: self definition.
        aFileStream command: '/H3'.

    self organization
        putCommentOnFile: aFileStream
        numbered: fileIndex
        moveSource: moveSource
        forClass: self.
    self organization categories do:
        [:heading |
        self fileOutCategory: heading
            on: aFileStream
            moveSource: moveSource
            toFile: fileIndex]! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/28/97 20:35'!
fileOutOrganizationOn: aFileStream
    "File a description of the receiver's organization on aFileStream."

    aFileStream cr; nextPut: $!!.
    aFileStream nextChunkPut: self name, ' reorganize'; cr.
    aFileStream nextChunkPut: self organization printString; cr! !

!ClassDescription methodsFor: 'fileIn/Out'!
kindOfSubclass
    "Answer a string that describes what kind of subclass the receiver is, i.e.,
    variable, variable byte, variable word, or not variable."

    self isVariable
        ifTrue: [self isBits
                    ifTrue: [self isBytes
                                ifTrue: [^' variableByteSubclass: ']
                                ifFalse: [^' variableWordSubclass: ']]
                    ifFalse: [^' variableSubclass: ']]
        ifFalse: [^' subclass: ']! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
methods
    "Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V"

    ^ ClassCategoryReader new setClass: self
                            category: 'as yet unclassified' asSymbol! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/29/97 13:00'!
methodsFor: categoryName
    "Answer a ClassCategoryReader for compiling the messages in the category, categoryName, of the receiver."

    ^ ClassCategoryReader new setClass: self category: categoryName asSymbol

    "(False methodsFor: 'logical operations') inspect"! !

!ClassDescription methodsFor: 'fileIn/Out'!
methodsFor: aString priorSource: sourcePosition inFile: fileIndex
    "Prior source pointer ignored when filing in."
    ^ self methodsFor: aString! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/13/97 13:51'!
methodsFor: categoryName stamp: changeStamp
    ^ self methodsFor: categoryName stamp: (Utilities fixStamp: changeStamp) prior: 0! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
methodsFor: categoryName stamp: changeStamp prior: indexAndOffset
    "Prior source link ignored when filing in."
    ^ ClassCategoryReader new setClass: self
                category: categoryName asSymbol
                changeStamp: changeStamp
! !

!ClassDescription methodsFor: 'fileIn/Out'!
moveChangesTo: newFile
    "Used in the process of condensing changes, this message requests that
    the source code of all methods of the receiver that have been changed
    should be moved to newFile."

    | changes |
    self organization moveChangedCommentToFile: newFile numbered: 2.
    changes _ methodDict keys select: [:sel | (methodDict at: sel) fileIndex > 1].
    self fileOutChangedMessages: changes
        on: newFile
        moveSource: true
        toFile: 2! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
printCategoryChunk: categoryName on: aFileStream
    ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/5/97 di'!
printCategoryChunk: category on: aFileStream priorMethod: priorMethod
    ^ self printCategoryChunk: category on: aFileStream
        withStamp: Utilities changeStamp priorMethod: priorMethod! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 6/26/97 11:51'!
printCategoryChunk: category on: aFileStream withStamp: changeStamp priorMethod: priorMethod
    "Print a method category preamble.  This must have a category name.
    It may have an author/date stamp, and it may have a prior source link.
    If it has a prior source link, it MUST have a stamp, even if it is empty."

"The current design is that changeStamps and prior source links are preserved in the changes file.  All fileOuts include changeStamps.  Condensing sources, however, eliminates all stamps (and links, natch)."

    aFileStream cr; command: 'H3'; nextPut: $!!.
    aFileStream nextChunkPut: (String streamContents:
        [:strm |
        strm nextPutAll: self name; nextPutAll: ' methodsFor: '; print: category asString.
        (changeStamp size > 0 or: [priorMethod ~~ nil]) ifTrue:
            [strm nextPutAll: ' stamp: '; print: changeStamp].
        priorMethod ~~ nil ifTrue:
            [strm nextPutAll: ' prior: '; print: priorMethod sourcePointer]]).
    aFileStream command: '/H3'.! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: '6/6/97 di'!
printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream
    ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp
        priorMethod: nil! !

!ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 12/15/97 15:01'!
printMethodChunk: selector withPreamble: doPreamble on: outStream
        moveSource: moveSource toFile: fileIndex
    "Copy the source code for the method associated with selector onto the fileStream.  If moveSource true, then also set the source code pointer of the method."
    | preamble method oldPos newPos sourceFile |
    doPreamble
        ifTrue: [preamble _ self name , ' methodsFor: ' ,
                    (self organization categoryOfElement: selector) asString printString]
        ifFalse: [preamble _ ''].
    method _ methodDict at: selector.
    ((method fileIndex = 0
        or: [(SourceFiles at: method fileIndex) == nil])
        or: [(oldPos _ method filePosition) = 0])
        ifTrue:
        ["The source code is not accessible.  We must decompile..."
        preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr].
        outStream nextChunkPut: (self decompilerClass new decompile: selector
                                            in: self method: method) decompileString]
        ifFalse:
        [sourceFile _ SourceFiles at: method fileIndex.
        sourceFile position: oldPos.
        preamble size > 0 ifTrue:    "Copy the preamble"
            [outStream copyPreamble: preamble from: sourceFile].
        "Copy the method chunk"
        newPos _ outStream position.
        outStream copyMethodChunkFrom: sourceFile.
        sourceFile skipSeparators.    "The following chunk may have ]style["
        sourceFile peek == $] ifTrue: [
            outStream cr; copyMethodChunkFrom: sourceFile].
        moveSource ifTrue:    "Set the new method source pointer"
            [method setSourcePosition: newPos inFile: fileIndex]].
    preamble size > 0 ifTrue: [outStream nextChunkPut: ' '].
    ^ outStream cr.
! !

!ClassDescription methodsFor: 'fileIn/Out'!
reformatAll
    "Reformat all methods in this class.
    Leaves old code accessible to version browsing"
    self selectorsDo: [:sel | self reformatMethodAt: sel]! !

!ClassDescription methodsFor: 'fileIn/Out'!
reformatMethodAt: selector
    | newCodeString method |
    newCodeString _ (self compilerClass new)
        format: (self sourceCodeAt: selector)
        in: self
        notifying: nil.
    method _ self compiledMethodAt: selector.
    method
        putSource: newCodeString
        fromParseNode: nil
        class: self
        category: (self organization categoryOfElement: selector)
        inFile: 2 priorMethod: method! !

!ClassDescription methodsFor: 'fileIn/Out'!
reorganize
    "Record that the receiver is being reorganized and answer the receiver's organization."

    Smalltalk changes reorganizeClass: self.
    ^self organization! !


!ClassDescription methodsFor: 'private'!
errorCategoryName
    self error: 'Category name must be a String'! !

!ClassDescription methodsFor: 'private' stamp: 'di 1/30/98 11:56'!
spaceUsed
    "Answer a rough estimate of number of bytes in this class and its metaclass"
    | space method |
    space _ 0.
    self selectorsDo:
        [:sel | space _ space + 16.  "dict and org'n space"
        method _ self compiledMethodAt: sel.
        space _ space + (method size + 6 "hdr + avg pad").
        method literals do:
            [:lit | ((lit isMemberOf: Symbol) or: [lit isMemberOf: SmallInteger]) ifFalse:
                [(lit isMemberOf: String) ifTrue: [space _ space + (lit size+6)].
                (lit isMemberOf: Array) ifTrue: [space _ space + (lit size+1*4)]]]].
    (self isMemberOf: Metaclass)
        ifTrue: [^ space]
        ifFalse: [^ space + self class spaceUsed]! !
Object subclass: #ClassOrganizer
    instanceVariableNames: 'globalComment categoryArray categoryStops elementArray '
    classVariableNames: 'Default NullCategory '
    poolDictionaries: ''
    category: 'Kernel-Classes'!
!ClassOrganizer commentStamp: 'di 5/22/1998 16:32' prior: 0!
ClassOrganizer comment:
'I represent method categorization information for classes.'!


!ClassOrganizer methodsFor: 'accessing'!
categories
    "Answer an Array of categories (names)."
    (categoryArray size = 1
        and: [categoryArray first = Default & (elementArray size = 0)])
        ifTrue: [^Array with: NullCategory].
    ^categoryArray! !

!ClassOrganizer methodsFor: 'accessing'!
categories: anArray
    "Reorder my categories to be in order of the argument, anArray. If the
    resulting organization does not include all elements, then give an error."

    | newCategories newStops newElements catName list runningTotal |
    newCategories _ Array new: anArray size.
    newStops _ Array new: anArray size.
    newElements _ Array new: 0.
    runningTotal _ 0.
    1 to: anArray size do:
        [:i |
        catName _ (anArray at: i) asSymbol.
        list _ self listAtCategoryNamed: catName.
                newElements _ newElements, list.
                newCategories at: i put: catName.
                newStops at: i put: (runningTotal _ runningTotal + list size)].
    elementArray do:
        [:element | "check to be sure all elements are included"
        (newElements includes: element)
            ifFalse: [^self error: 'New categories must match old ones']].
    "Everything is good, now update my three arrays."
    categoryArray _ newCategories.
    categoryStops _ newStops.
    elementArray _ newElements! !

!ClassOrganizer methodsFor: 'accessing'!
categoryOfElement: element
    "Answer the category associated with the argument, element."

    | index |
    index _ self numberOfCategoryOfElement: element.
    index = 0
        ifTrue: [^nil]
        ifFalse: [^categoryArray at: index]! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 9/30/97 11:00'!
changeFromString: aString
    "Parse the argument, aString, and make this be the receiver's structure."

    | scanner oldElements newElements newCategories newStops currentStop anArray temp ii cc |
    scanner _ Scanner new scanTokens: aString.
    "If nothing was scanned and I had no elements before, then default me"
    (scanner size = 0 and: [elementArray size = 0])
        ifTrue: [^self setDefaultList: Array new].

    oldElements _ elementArray asSet.
    newCategories _ Array new: scanner size.
    newStops _ Array new: scanner size.
    currentStop _ 0.
    newElements _ WriteStream on: (Array new: 16).
    1 to: scanner size do:
        [:i |
        anArray _ scanner at: i.
        newCategories at: i put: anArray first asSymbol.
        anArray allButFirst asSortedCollection do:
            [:elem |
            (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
                [newElements nextPut: elem.
                currentStop _ currentStop+1]].
        newStops at: i put: currentStop].

    "Ignore extra elements but don't lose any existing elements!!"
    oldElements _ oldElements collect:
        [:elem | Array with: (self categoryOfElement: elem) with: elem].
    newElements _ newElements contents.
    categoryArray _ newCategories.
    (cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element"
        temp _ categoryArray asOrderedCollection.
        temp removeAll: categoryArray asSet asOrderedCollection.
        temp do: [:dup |
            ii _ categoryArray indexOf: dup.
            [dup _ (dup,' #2') asSymbol.  cc includes: dup] whileTrue.
            cc add: dup.
            categoryArray at: ii put: dup]].
    categoryStops _ newStops.
    elementArray _ newElements.
    oldElements do: [:pair | self classify: pair last under: pair first].! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/12/97 13:32'!
classComment
    "Answer the comment associated with the object that refers to the
    receiver."

    globalComment == nil ifTrue: [^''].
    ^globalComment text! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/16/97 07:44'!
classComment: aString
    "Store the comment, aString, associated with the object that refers to the
    receiver."

    (aString isKindOf: RemoteString)
        ifTrue: [globalComment _ aString]
        ifFalse: [aString size = 0
            ifTrue: [globalComment _ nil]
            ifFalse: [
                self error: 'use aClass classComment:'.
                globalComment _ RemoteString newString: aString onFileNumber: 2]]
                "Later add priorSource and date and initials?"! !

!ClassOrganizer methodsFor: 'accessing' stamp: 'tk 12/15/97 14:41'!
commentRemoteStr
    ^ globalComment! !

!ClassOrganizer methodsFor: 'accessing'!
hasNoComment
    "Answer whether the class classified by the receiver has a comment."

    ^globalComment == nil! !

!ClassOrganizer methodsFor: 'accessing'!
listAtCategoryNamed: categoryName
    "Answer the array of elements associated with the name, categoryName."

    | i |
    i _ categoryArray indexOf: categoryName ifAbsent: [^Array new].
    ^self listAtCategoryNumber: i! !

!ClassOrganizer methodsFor: 'accessing'!
listAtCategoryNumber: anInteger
    "Answer the array of elements stored at the position indexed by
    anInteger."

    | firstIndex lastIndex |
    firstIndex _
        (anInteger > 1
            ifTrue: [categoryStops at: anInteger - 1]
            ifFalse: [0])
        + 1.
    lastIndex _ categoryStops at: anInteger.
    ^elementArray copyFrom: firstIndex to: lastIndex! !

!ClassOrganizer methodsFor: 'accessing'!
numberOfCategoryOfElement: element
    "Answer the index of the category with which the argument, element, is
    associated."

    | categoryIndex elementIndex |
    categoryIndex _ 1.
    elementIndex _ 0.
    [(elementIndex _ elementIndex + 1) <= elementArray size]
        whileTrue:
            ["point to correct category"
            [elementIndex > (categoryStops at: categoryIndex)]
                whileTrue: [categoryIndex _ categoryIndex + 1].
            "see if this is element"
            element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]].
    ^0! !

!ClassOrganizer methodsFor: 'accessing'!
removeElement: element
    "Remove the selector, element, from all categories."
    | categoryIndex elementIndex nextStop newElements |
    categoryIndex _ 1.
    elementIndex _ 0.
    nextStop _ 0.
    "nextStop keeps track of the stops in the new element array"
    newElements _ WriteStream on: (Array new: elementArray size).
    [(elementIndex _ elementIndex + 1) <= elementArray size]
        whileTrue:
            [[elementIndex > (categoryStops at: categoryIndex)]
                whileTrue:
                    [categoryStops at: categoryIndex put: nextStop.
                    categoryIndex _ categoryIndex + 1].
            (elementArray at: elementIndex) = element
                ifFalse:
                    [nextStop _ nextStop + 1.
                    newElements nextPut: (elementArray at: elementIndex)]].
    [categoryIndex <= categoryStops size]
        whileTrue:
            [categoryStops at: categoryIndex put: nextStop.
            categoryIndex _ categoryIndex + 1].
    elementArray _ newElements contents! !

!ClassOrganizer methodsFor: 'accessing'!
removeEmptyCategories
    "Remove empty categories."

    | categoryIndex currentStop keptCategories keptStops |
    keptCategories _ WriteStream on: (Array new: 16).
    keptStops _ WriteStream on: (Array new: 16).
    currentStop _ categoryIndex _ 0.
    [(categoryIndex _ categoryIndex + 1) <= categoryArray size]
        whileTrue:
            [(categoryStops at: categoryIndex) > currentStop
                ifTrue:
                    [keptCategories nextPut: (categoryArray at: categoryIndex).
                    keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]].
    categoryArray _ keptCategories contents.
    categoryStops _ keptStops contents.
    categoryArray size = 0
        ifTrue:
            [categoryArray _ Array with: Default.
            categoryStops _ Array with: 0]

    "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !


!ClassOrganizer methodsFor: 'compiler access' stamp: 'tk 5/18/1998 11:32'!
classify: element under: heading
    "Store the argument, element, in the category named heading."

    | catName catIndex elemIndex realHeading |
    ((heading = NullCategory) or: [heading == nil])
        ifTrue: [realHeading _ Default]
        ifFalse: [realHeading _ heading asSymbol].
    (catName _ self categoryOfElement: element) = realHeading
        ifTrue: [^self].  "done if already under that category"

    catName ~~ nil ifTrue:
        [realHeading = Default
            ifTrue: [^self].    "return if exists and realHeading is default"
        self removeElement: element].    "remove if in another category"

    (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].
    "add realHeading if not there already"

    catIndex _ categoryArray indexOf: realHeading.
    elemIndex _
        catIndex > 1
            ifTrue: [categoryStops at: catIndex - 1]
            ifFalse: [0].
    [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex)
        and: [element >= (elementArray at: elemIndex)]] whileTrue.

    "elemIndex is now the index for inserting the element. Do the insertion before it."
    elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1
                        with: (Array with: element).

    "add one to stops for this and later categories"
    catIndex to: categoryArray size do:
        [:i | categoryStops at: i put: (categoryStops at: i) + 1].
    (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! !

!ClassOrganizer methodsFor: 'compiler access'!
classifyAll: aCollection under: heading

    aCollection do:
        [:element | self classify: element under: heading]! !


!ClassOrganizer methodsFor: 'method dictionary'!
addCategory: newCategory
    ^ self addCategory: newCategory before: nil ! !

!ClassOrganizer methodsFor: 'method dictionary'!
addCategory: catString before: nextCategory
    "Add a new category named heading.
    If default category exists and is empty, remove it.
    If nextCategory is nil, then add the new one at the end,
    otherwise, insert it before nextCategory."
    | index newCategory |
    newCategory _ catString asSymbol.
    (categoryArray indexOf: newCategory) > 0
        ifTrue: [^self].    "heading already exists, so done"
    index _ categoryArray indexOf: nextCategory
        ifAbsent: [categoryArray size + 1].
    categoryArray _ categoryArray
        copyReplaceFrom: index
        to: index-1
        with: (Array with: newCategory).
    categoryStops _ categoryStops
        copyReplaceFrom: index
        to: index-1
        with: (Array with: (index = 1
                ifTrue: [0]
                ifFalse: [categoryStops at: index-1])).
    "remove empty default category"
    (newCategory ~= Default
            and: [(self listAtCategoryNamed: Default) isEmpty])
        ifTrue: [self removeCategory: Default]! !

!ClassOrganizer methodsFor: 'method dictionary'!
removeCategory: cat
    "Remove the category named, cat. Create an error notificiation if the
    category has any elements in it."

    | index lastStop |
    index _ categoryArray indexOf: cat ifAbsent: [^self].
    lastStop _
        index = 1
            ifTrue: [0]
            ifFalse: [categoryStops at: index - 1].
    (categoryStops at: index) - lastStop > 0
        ifTrue: [^self error: 'cannot remove non-empty category'].
    categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new.
    categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new.
    categoryArray size = 0
        ifTrue:
            [categoryArray _ Array with: Default.
            categoryStops _ Array with: 0]
! !

!ClassOrganizer methodsFor: 'method dictionary'!
renameCategory: oldCatString toBe: newCatString
    "Rename a category. No action if new name already exists,
    or if old name does not exist."
    | index oldCategory newCategory |
    oldCategory _ oldCatString asSymbol.
    newCategory _ newCatString asSymbol.
    (categoryArray indexOf: newCategory) > 0
        ifTrue: [^self].    "new name exists, so no action"
    (index _ categoryArray indexOf: oldCategory) = 0
        ifTrue: [^self].    "old name not found, so no action"
    categoryArray at: index put: newCategory! !


!ClassOrganizer methodsFor: 'printing'!
printOn: aStream
    "Refer to the comment in Object|printOn:."

    | elementIndex lastStop |
    elementIndex _ 1.
    lastStop _ 1.
    1 to: categoryArray size do:
        [:i |
        aStream nextPut: $(.
        (categoryArray at: i) asString printOn: aStream.
        [elementIndex <= (categoryStops at: i)]
            whileTrue:
                [aStream space.
                (elementArray at: elementIndex) printOn: aStream.
                elementIndex _ elementIndex + 1].
        aStream nextPut: $).
        aStream cr]! !


!ClassOrganizer methodsFor: 'fileIn/Out'!
fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex
    "Copy the class comment to aFileStream.  If moveSource is true (as in compressChanges or compressSources, then update globalComment to point to the new file."
    | fileComment |
    globalComment ifNotNil:
            [aFileStream cr.
            fileComment _ RemoteString newString: globalComment text
                            onFileNumber: fileIndex toFile: aFileStream.
            moveSource ifTrue: [globalComment _ fileComment]]! !

!ClassOrganizer methodsFor: 'fileIn/Out'!
moveChangedCommentToFile: aFileStream numbered: fileIndex
    "If the comment is in the changes file, then move it to a new file."

    (globalComment ~~ nil and: [globalComment sourceFileNumber > 1]) ifTrue:
        [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! !

!ClassOrganizer methodsFor: 'fileIn/Out'!
putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass
    "Store the comment about the class onto file, aFileStream."
    | header |
    globalComment ifNotNil:
        [aFileStream cr; nextPut: $!!.
        header _ String streamContents: [:strm |
                strm nextPutAll: aClass name;
                nextPutAll: ' commentStamp: '.
                Utilities changeStamp storeOn: strm.
                strm nextPutAll: ' prior: '; nextPutAll: '0'].
        aFileStream nextChunkPut: header.
        aClass organization fileOutCommentOn: aFileStream
                moveSource: moveSource toFile: sourceIndex.
        aFileStream cr]! !

!ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'di 1/13/98 16:57'!
scanFrom: aStream
    "Reads in the organization from the next chunk on aStream.
    Categories or elements not found in the definition are not affected.
    New elements are ignored."

    self changeFromString: aStream nextChunk.
    aStream skipStyleChunk.! !


!ClassOrganizer methodsFor: 'private' stamp: 'tk 12/16/97 07:35'!
setDefaultList: aSortedCollection

    self classComment: ''.
    categoryArray _ Array with: Default.
    categoryStops _ Array with: aSortedCollection size.
    elementArray _ aSortedCollection asArray! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ClassOrganizer class
    instanceVariableNames: ''!

!ClassOrganizer class methodsFor: 'class initialization'!
default
    ^ Default! !

!ClassOrganizer class methodsFor: 'class initialization'!
initialize
    Default _ 'as yet unclassified' asSymbol.
    NullCategory _ 'no messages' asSymbol.
    "ClassOrganizer initialize"! !

!ClassOrganizer class methodsFor: 'class initialization'!
nullCategory
    ^ NullCategory! !


!ClassOrganizer class methodsFor: 'instance creation'!
defaultList: aSortedCollection
    "Answer an instance of me with initial elements from the argument,
    aSortedCollection."

    ^self new setDefaultList: aSortedCollection! !


!ClassOrganizer class methodsFor: 'documentation'!
documentation
    "Instances consist of an Array of category names (categoryArray), each of
    which refers to an Array of elements (elementArray). This association is
    made through an Array of stop indices (categoryStops), each of which is
    the index in elementArray of the last element (if any) of the
    corresponding category. For example: categories _ Array with: 'firstCat'
    with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4.
    elements _ Array with: #a with: #b with: #c with: #d. This means that
    category firstCat has only #a, secondCat has #b, #c, and #d, and
    thirdCat has no elements. This means that stops at: stops size must be the
    same as elements size." ! !
StringMorph subclass: #ClockMorph
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Demo'!

!ClockMorph methodsFor: 'all' stamp: 'sw 2/9/98 01:23'!
step
    super step.
    self contents: Time now printString.! !

!ClockMorph methodsFor: 'all'!
stepTime
    "Answer the desired time between steps in milliseconds."

    ^ 1000! !
ServerAction subclass: #CodeServer
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!CodeServer commentStamp: 'di 5/22/1998 16:32' prior: 0!
Return the source code from Smalltalk, as web page text, or as a raw Squeak file chunk.
URLs are of the form:
    machine:80/smtlk.Point|min;            <-- NOTE: use ; instead of :
    machine:80/smtlk.{Class}|{selector}
    machine:80/chunk.{Class}|{selector}

    machine:80/smtlk.{Class}|class|{selector}
    machine:80/chunk.{Class}|class|{selector}

    machine:80/smtlk.{Class}|Definition
    machine:80/chunk.{Class}|Definition

    machine:80/smtlk.{Class}|Hierarchy
    machine:80/chunk.{Class}|Hierarchy

    machine:80/smtlk.{Class}|Comment
    machine:80/chunk.{Class}|Comment
NOTE: use ; semicolon instead of : colon in selector names
!


!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'!
chunk: request
    "Return Smalltalk source code as a chunk from the changes file.
URL = machine:80/chunk.Point|min;  included are:  Point|at;   Point|Comment   Point|Hierarchy  Point|Definition   Point|class|x;y;
    Meant to be received by a Squeak client, not a browser.  Reply not in HTML"

    | classAndMethod set strm chunk |
    classAndMethod _ request message atPin: 2.
    classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '.
    classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'.
    set _ LinkedMessageSet messageList: (Array with: classAndMethod).
    strm _ WriteStream on: (String new: 300).
    strm nextChunkPutWithStyle: (set selectedMessage). "String or text"
    chunk _ strm contents.

    request reply: 'content-length: ', chunk size printString, PWS crlfcrlf.
    request reply: chunk.
! !

!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:35'!
process: request
    "Return the source code from Smalltalk, as text or as a chunk.
URLs are of this form.  Each may have 'chunk' or 'smtlk' as the thing after the slash
    machine:80/smtlk.Point|min;
    machine:80/chunk.{Class}|{selector}
    machine:80/smtlk.{Class}|{selector}
    machine:80/smtlk.{Class}|class|{selector}
    machine:80/smtlk.{Class}|Definition
    machine:80/smtlk.{Class}|Hierarchy
    machine:80/smtlk.{Class}|Comment
NOTE: use ; semicolon instead of : colon in selector names!!!!!!"

    | coreRef |
    coreRef _ (request message at: 1) asLowercase.
    request reply: PWS success; reply: PWS contentHTML.
    Transcript show: 'In process: ', request message printString; cr.
    coreRef = 'smtlk' ifTrue: [^ self smtlk: request].
    coreRef = 'chunk' ifTrue: [^ self chunk: request].
    request reply: ( 'HTTP/1.0 400 Bad Request', PWS crlfcrlf,
        'expected smtlk.{Class}|{selector} or chunk.{Class}|{selector}').    "failure"! !

!CodeServer methodsFor: 'as yet unclassified' stamp: 'tk 5/7/1998 15:36'!
smtlk: request
    "Return Smalltalk sourcecode in HTML.  URL = machine:80/myswiki.smtlk.Point|min;  included are:  Point|min;   Point|Comment   Point|Hierarchy  Point|Definition   Point|class|x;y;
NOTE: use ; instead of : in selector names!!!!!!"

    | classAndMethod set |
    classAndMethod _ request message atPin: 2.
    classAndMethod _ classAndMethod copyReplaceAll: '|' with: ' '.
    classAndMethod _ classAndMethod copyReplaceAll: ';' with: ':'.
    set _ LinkedMessageSet messageList: (Array with: classAndMethod).

    request reply: PWS crlf, (HTMLformatter
                evalEmbedded: (self fileContents: 'swiki',(ServerAction pathSeparator),'smtlk.html')
                with: set).! !
Object subclass: #Collection
    instanceVariableNames: ''
    classVariableNames: 'RandomForPicking '
    poolDictionaries: ''
    category: 'Collections-Abstract'!
!Collection commentStamp: 'di 5/22/1998 16:32' prior: 0!
Collection comment:
'I am the abstract superclass of all classes that represent a group of elements.'!


!Collection methodsFor: 'accessing'!
size
    "Answer how many elements the receiver contains."

    | tally |
    tally _ 0.
    self do: [:each | tally _ tally + 1].
    ^tally! !


!Collection methodsFor: 'testing'!
includes: anObject
    "Answer whether anObject is one of the receiver's elements."

    self do: [:each | anObject = each ifTrue: [^true]].
    ^false! !

!Collection methodsFor: 'testing'!
includesAllOf: aCollection
    "Answer whether all the elements of aCollection are in the receiver."
    aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
    ^ true! !

!Collection methodsFor: 'testing'!
includesAnyOf: aCollection
    "Answer whether any element of aCollection is one of the receiver's elements."
    aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]].
    ^ false! !

!Collection methodsFor: 'testing' stamp: 'sw 8/12/97 20:59'!
includesSubstringAnywhere: testString
    "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring"
    self do:
        [:element |
            (element isKindOf: String)
                ifTrue:
                    [(element includesSubString: testString) ifTrue: [^ true]].
            (element isKindOf: Collection)
                ifTrue:
                    [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]].
    ^ false

"#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere:  'lvi'"! !

!Collection methodsFor: 'testing'!
isEmpty
    "Answer whether the receiver contains any elements."

    ^self size = 0! !

!Collection methodsFor: 'testing'!
occurrencesOf: anObject
    "Answer how many of the receiver's elements are equal to anObject."

    | tally |
    tally _ 0.
    self do: [:each | anObject = each ifTrue: [tally _ tally + 1]].
    ^tally! !


!Collection methodsFor: 'adding'!
add: newObject
    "Include newObject as one of the receiver's elements. Answer newObject.
    ArrayedCollections cannot respond to this message."

    self subclassResponsibility! !

!Collection methodsFor: 'adding'!
addAll: aCollection
    "Include all the elements of aCollection as the receiver's elements. Answer
    aCollection."

    aCollection do: [:each | self add: each].
    ^aCollection! !

!Collection methodsFor: 'adding' stamp: 'tk 5/7/1998 13:00'!
addIfNotPresent: anObject

    (self includes: anObject) ifFalse: [^ self add: anObject]! !


!Collection methodsFor: 'removing'!
remove: oldObject
    "Remove oldObject as one of the receiver's elements. Answer oldObject
    unless no element is equal to oldObject, in which case, create an error
    notification."

    ^self remove: oldObject ifAbsent: [self errorNotFound]! !

!Collection methodsFor: 'removing'!
remove: oldObject ifAbsent: anExceptionBlock
    "Remove oldObject as one of the receiver's elements. If several of the
    elements are equal to oldObject, only one is removed. If no element is
    equal to oldObject, answer the result of evaluating anExceptionBlock.
    Otherwise, answer the argument, oldObject. SequenceableCollections
    cannot respond to this message."

    self subclassResponsibility! !

!Collection methodsFor: 'removing'!
removeAll: aCollection
    "Remove each element of aCollection from the receiver. If successful for
    each, answer aCollection. Otherwise create an error notification."

    aCollection do: [:each | self remove: each].
    ^aCollection! !

!Collection methodsFor: 'removing'!
removeAllFoundIn: aCollection
    "Remove each element of aCollection which is present in the receiver from the receiver"

    aCollection do: [:each | self remove: each ifAbsent: []].
    ^aCollection! !

!Collection methodsFor: 'removing'!
removeAllSuchThat: aBlock
    "Apply the condition to each element and remove it if the condition is true.  Use a copy to enumerate collections whose order changes when an element is removed (Set)."
    | copy newCollection |
    newCollection _ self species new.
    copy _ self copy.
    copy do: [:element |
        (aBlock value: element) ifTrue: [
            self remove: element.
            newCollection add: element]].
    ^ newCollection! !


!Collection methodsFor: 'enumerating'!
associationsDo: aBlock
    "Evaluate aBlock for each of the receiver's elements (key/value
    associations).  If any non-association is within, the error is not caught now,
    but later, when a key or value message is sent to it."

    self do: aBlock! !

!Collection methodsFor: 'enumerating' stamp: 'jm 10/16/97 21:25'!
average
    "Return the average of all my elements."

    ^ self sum asFloat / self size
! !

!Collection methodsFor: 'enumerating'!
collect: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Collect the resulting values into a collection like the receiver. Answer
    the new collection."

    | newCollection |
    newCollection _ self species new.
    self do: [:each | newCollection add: (aBlock value: each)].
    ^newCollection! !

!Collection methodsFor: 'enumerating'!
collect: collectBlock thenSelect: selectBlock
    ^ (self collect: collectBlock) select: selectBlock! !

!Collection methodsFor: 'enumerating'!
count: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.  Return the number that answered true."

    | sum |
    sum _ 0.
    self do: [:each |
        (aBlock value: each) ifTrue: [sum _ sum + 1]].
    ^ sum! !

!Collection methodsFor: 'enumerating'!
detect: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Answer the first element for which aBlock evaluates to true."

    ^self detect: aBlock ifNone: [self errorNotFound]! !

!Collection methodsFor: 'enumerating'!
detect: aBlock ifNone: exceptionBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Answer the first element for which aBlock evaluates to true. If none
    evaluate to true, then evaluate the argument, exceptionBlock."

    self do: [:each | (aBlock value: each) ifTrue: [^each]].
    ^exceptionBlock value! !

!Collection methodsFor: 'enumerating'!
detectMax: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Answer the element for which aBlock evaluates to the highest magnitude.
    If collection empty, return nil.  This method might also be called elect:."

    | maxElement maxValue val |
    self do: [:each |
        maxValue == nil
            ifFalse: [
                (val _ aBlock value: each) > maxValue ifTrue: [
                    maxElement _ each.
                    maxValue _ val]]
            ifTrue: ["first element"
                maxElement _ each.
                maxValue _ aBlock value: each].
                "Note that there is no way to get the first element that works
                for all kinds of Collections.  Must test every one."].
    ^ maxElement! !

!Collection methodsFor: 'enumerating'!
detectMin: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Answer the element for which aBlock evaluates to the lowest number.
    If collection empty, return nil."

    | minElement minValue val |
    self do: [:each |
        minValue == nil
            ifFalse: [
                (val _ aBlock value: each) < minValue ifTrue: [
                    minElement _ each.
                    minValue _ val]]
            ifTrue: ["first element"
                minElement _ each.
                minValue _ aBlock value: each].
                "Note that there is no way to get the first element that works
                for all kinds of Collections.  Must test every one."].
    ^ minElement! !

!Collection methodsFor: 'enumerating'!
detectSum: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Return the sum of the answers."
    | sum |
    sum _ 0.
    self do: [:each |
        sum _ (aBlock value: each) + sum].
    ^ sum! !

!Collection methodsFor: 'enumerating'!
do: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument."

    self subclassResponsibility! !

!Collection methodsFor: 'enumerating'!
inject: thisValue into: binaryBlock
    "Accumulate a running value associated with evaluating the argument,
    binaryBlock, with the current value of the argument, thisValue, and the
    receiver as block arguments. For instance, to sum the numeric elements
    of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal +
    next]."

    | nextValue |
    nextValue _ thisValue.
    self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
    ^nextValue! !

!Collection methodsFor: 'enumerating' stamp: 'jm 11/14/97 11:08'!
max
    "Return the max of all my elements."
    | max | max _ nil.
    self do: [:each | (max == nil or: [each > max])
                    ifTrue: [max _ each]].
    ^ max! !

!Collection methodsFor: 'enumerating'!
reject: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Collect into a new collection like the receiver only those elements for
    which aBlock evaluates to false. Answer the new collection."

    ^self select: [:element | (aBlock value: element) == false]! !

!Collection methodsFor: 'enumerating'!
select: aBlock
    "Evaluate aBlock with each of the receiver's elements as the argument.
    Collect into a new collection like the receiver, only those elements for
    which aBlock evaluates to true. Answer the new collection."

    | newCollection |
    newCollection _ self species new.
    self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]].
    ^newCollection! !

!Collection methodsFor: 'enumerating'!
select: selectBlock thenCollect: collectBlock
    ^ (self select: selectBlock) collect: collectBlock! !

!Collection methodsFor: 'enumerating' stamp: 'di 7/5/97 14:56'!
sum
    "Return the sum of all my elements."
    | sum |  sum _ 0.
    self do: [:each | sum _ sum + each].
    ^ sum! !


!Collection methodsFor: 'converting'!
asBag
    "Answer a Bag whose elements are the elements of the receiver."

    | aBag |
    aBag _ Bag new.
    self do: [:each | aBag add: each].
    ^aBag! !

!Collection methodsFor: 'converting'!
asOrderedCollection
    "Answer an OrderedCollection whose elements are the elements of the
    receiver. The order in which elements are added depends on the order in
    which the receiver enumerates its elements. In the case of unordered
    collections, the ordering is not necessarily the same for multiple requests
    for the conversion."

    | anOrderedCollection |
    anOrderedCollection _ OrderedCollection new: self size.
    self do: [:each | anOrderedCollection addLast: each].
    ^anOrderedCollection! !

!Collection methodsFor: 'converting'!
asSet
    "Answer a Set whose elements are the unique elements of the receiver."

    | aSet |
    aSet _ Set new: self size.
    self do: [:each | aSet add: each].
    ^aSet! !

!Collection methodsFor: 'converting'!
asSortedArray
    "Return a copy of the receiver in sorted order, as an Array.  6/10/96 sw"

    ^ self asSortedCollection asArray! !

!Collection methodsFor: 'converting'!
asSortedCollection
    "Answer a SortedCollection whose elements are the elements of the
    receiver. The sort order is the default less than or equal."

    | aSortedCollection |
    aSortedCollection _ SortedCollection new: self size.
    aSortedCollection addAll: self.
    ^aSortedCollection! !

!Collection methodsFor: 'converting'!
asSortedCollection: aBlock
    "Answer a SortedCollection whose elements are the elements of the
    receiver. The sort order is defined by the argument, aBlock."

    | aSortedCollection |
    aSortedCollection _ SortedCollection new: self size.
    aSortedCollection sortBlock: aBlock.
    aSortedCollection addAll: self.
    ^aSortedCollection! !


!Collection methodsFor: 'printing' stamp: 'di 6/20/97 09:09'!
printOn: aStream
    "Refer to the comment in Object|printOn:."
    aStream nextPutAll: self class name, ' ('.
    self do: [:element | element printOn: aStream. aStream space].
    aStream nextPut: $)! !

!Collection methodsFor: 'printing'!
storeOn: aStream
    "Refer to the comment in Object|storeOn:."

    | noneYet |
    aStream nextPutAll: '(('.
    aStream nextPutAll: self class name.
    aStream nextPutAll: ' new)'.
    noneYet _ true.
    self do:
        [:each |
        noneYet
            ifTrue: [noneYet _ false]
            ifFalse: [aStream nextPut: $;].
        aStream nextPutAll: ' add: '.
        aStream store: each].
    noneYet ifFalse: [aStream nextPutAll: '; yourself'].
    aStream nextPut: $)! !


!Collection methodsFor: 'private'!
emptyCheck

    self isEmpty ifTrue: [self errorEmptyCollection]! !

!Collection methodsFor: 'private'!
errorEmptyCollection

    self error: 'this collection is empty'! !

!Collection methodsFor: 'private'!
errorNoMatch

    self error: 'collection sizes do not match'! !

!Collection methodsFor: 'private'!
errorNotFound

    self error: 'Object is not in the collection.'! !

!Collection methodsFor: 'private'!
errorNotKeyed

    self error: self class name, 's do not respond to keyed accessing messages.'! !

!Collection methodsFor: 'private'!
fill: numElements fromStack: aContext
    "Fill me with numElements elements, popped in reverse order from
     the stack of aContext.  Do not call directly: this is called indirectly by {1. 2. 3}
     constructs.  Subclasses that support at:put: instead of add: should override
     this and call Context<pop:toIndexable:"

    aContext pop: numElements toAddable: self! !

!Collection methodsFor: 'private'!
maxSize
    "Answer the largest basicSize which is valid for the receiver's class."

    ^65486 "for VM3 interpreter DoradoST80Aug19"! !

!Collection methodsFor: 'private'!
toBraceStack: itsSize
    "Push receiver's elements onto the stack of thisContext sender.  Error if receiver does
     not have itsSize elements or if receiver is unordered.
     Do not call directly: this is called by {a. b} _ ... constructs."

    self size ~= itsSize ifTrue:
        [self error: 'Trying to store ', self size printString,
                    ' values into ', itsSize printString, ' variables.'].
    thisContext sender push: itsSize fromIndexable: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Collection class
    instanceVariableNames: ''!

!Collection class methodsFor: 'instance creation'!
fromBraceStack: itsSize
    "Answer an instance of me with itsSize elements, popped in reverse order from
     the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
     constructs."

    ^ self newFrom: ((Array new: itsSize) fill: itsSize fromStack: thisContext sender)! !

!Collection class methodsFor: 'instance creation'!
with: anObject
    "Answer an instance of me containing anObject."

    | newCollection |
    newCollection _ self new.
    newCollection add: anObject.
    ^newCollection! !

!Collection class methodsFor: 'instance creation'!
with: firstObject with: secondObject
    "Answer an instance of me containing the two arguments as elements."

    | newCollection |
    newCollection _ self new.
    newCollection add: firstObject.
    newCollection add: secondObject.
    ^newCollection! !

!Collection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject
    "Answer an instance of me containing the three arguments as elements."

    | newCollection |
    newCollection _ self new.
    newCollection add: firstObject.
    newCollection add: secondObject.
    newCollection add: thirdObject.
    ^newCollection! !

!Collection class methodsFor: 'instance creation'!
with: firstObject with: secondObject with: thirdObject with: fourthObject
    "Answer an instance of me, containing the four arguments as the
    elements."

    | newCollection |
    newCollection _ self new.
    newCollection add: firstObject.
    newCollection add: secondObject.
    newCollection add: thirdObject.
    newCollection add: fourthObject.
    ^newCollection! !


!Collection class methodsFor: 'private'!
initialize
    "Set up a Random number generator to be used by pickOne when the user does not feel like creating his own Random generator."
    RandomForPicking _ Random new.
    ! !
Object subclass: #Color
    instanceVariableNames: 'rgb cachedDepth cachedBitPattern '
    classVariableNames: 'Black Blue BlueShift Brown CachedColormaps ColorChart ColorNames ComponentMask ComponentMax Cyan DarkGray Gray GrayToIndexMap Green GreenShift HalfComponentMask HighLightBitmaps IndexedColors LightBlue LightBrown LightCyan LightGray LightGreen LightMagenta LightOrange LightRed LightYellow Magenta MaskingMap OpaqueMask Orange PureBlue PureCyan PureGreen PureMagenta PureRed PureYellow RandomStream Red RedShift Transparent VeryDarkGray VeryLightGray VeryVeryDarkGray VeryVeryLightGray White Yellow '
    poolDictionaries: ''
    category: 'Graphics-Display Objects'!
!Color commentStamp: 'di 5/22/1998 16:32' prior: 0!
Color comment:
'This class represents abstract color, regardless of the depth of bitmap it will be shown in.  At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with.  The supported depths (in bits) are 1, 2, 4, 8, 16, and 32.  The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million.  (See comment in BitBlt.)  To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8).  (See comment in DisplayMedium)
    Color is represented as the amount of light in red, green, and blue.  White is (1.0, 1.0, 1.0) and black is (0, 0, 0).  Pure red is (1.0, 0, 0).  These colors are "additive".  Think of Color''s instance variables as:
    r    amount of red, a Float between 0.0 and 1.0.
    g    amount of green, a Float between 0.0 and 1.0.
    b    amount of blue, a Float between 0.0 and 1.0.
(But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb.  The user does not need to know this.)
    Many colors are named.  You find a color by name by sending a message to class Color, for example (Color lightBlue).  Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below)
    A color is essentially immutable.  Once you set red, green, and blue, you cannot change them.  Instead, create a new Color and use it.
    Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number.  Convert the range of this number to an integer from 1 to N.  Then call (Color green lightShades: N) to get an Array of colors from white to green.  Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array.  atPin: gives the first (or last) color if the index is out of range.  atWrap: wraps around to the other end if the index is out of range.
    Here are some fun things to run in when your screen has color:
        Pen new mandala: 30 diameter: Display height-100.
        Pen new web  "Draw with the mouse, opt-click to end"
        Display fillWhite.  Pen new hilberts: 5.
        Form toothpaste: 30  "Draw with mouse, opt-click to end"
You might also want to try the comment in
    Form>class>examples>tinyText...


Messages:
    mixed: proportion with: aColor    Answer this color mixed with the given color additively. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix.

    +     add two colors
    -     subtract two colors
    *    multiply the values of r, g, b by a number or an Array of factors.  ((Color named: #white) * 0.3) gives a darkish gray.  (aColor * #(0 0 0.9)) gives a color with slightly less blue.
    /    divide a color by a factor or an array of three factors.

    errorForDepth: d     How close the nearest color at this depth is to this abstract color.  Sum of the squares of the RGB differences, square rooted and normalized to 1.0.  Multiply by 100 to get percent.

    hue            Returns the hue of the color. On a wheel from 0 to 360 with pure red at 0 and again at 360.
    saturation    Returns the saturation of the color.  0.0 to 1.0
    brightness    Returns the brightness of the color.  0.0 to 1.0

    name    Look to see if this Color has a name.
    display    Show a swatch of this color tracking the cursor.

    lightShades: thisMany        An array of thisMany colors from white to the receiver.
    darkShades: thisMany        An array of thisMany colors from black to the receiver.  Array is of length num.
    mix: color2 shades: thisMany        An array of thisMany colors from the receiver to color2.
    wheel: thisMany            An array of thisMany colors around the color wheel starting and ending at the receiver.

    pixelValueForDepth: d    Returns the bits that appear be in a Bitmap of this depth for this color.  Represents the nearest available color at this depth.  Normal users do not need to know which pixelValue is used for which color.

Messages to Class Color.
    red: r green: g blue: b        Return a color with the given r, g, and b components.
    r: g: b:        Same as above, for fast typing.

     hue: h saturation: s brightness: b        Create a color with the given hue, saturation, and brightness.

    pink
     blue
    red ...    Many colors have messages that return an instance of Color.
    canUnderstand: #brown      Returns true if #brown is a defined color.
    names        An OrderedCollection of the names of the colors.
    named: #notAllThatGray put: aColor    Add a new color to the list and create an access message and a class variable for it.
    fromUser    Shows the palette of colors available at this display depth.  Click anywhere to return the color you clicked on.

    hotColdShades: thisMany    An array of thisMany colors showing temperature from blue to red to white hot.

    stdColorsForDepth: d        An Array of colors available at this depth.  For 16 bit and 32 bits, returns a ColorGenerator.  It responds to at: with a Color for that index, simulating a very big Array.

   colorFromPixelValue: value depth: d    Returns a Color whose bit pattern (inside a Bitmap) at this depth is the number specified.  Normal users do not need to use this.

(See also comments in these classes: Form, Bitmap, BitBlt, Pattern, MaskedForm.)'!


!Color methodsFor: 'access'!
alpha
    "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors."

    ^ 1.0
! !

!Color methodsFor: 'access'!
blue
    "Return the blue component of this color, a float in the range [0.0..1.0]."

    ^ self privateBlue asFloat / ComponentMax! !

!Color methodsFor: 'access'!
brightness
    "Return the brightness of this color, a float in the range [0.0..1.0]."

    ^ ((self privateRed max:
        self privateGreen) max:
        self privateBlue) asFloat / ComponentMax! !

!Color methodsFor: 'access'!
green
    "Return the green component of this color, a float in the range [0.0..1.0]."

    ^ self privateGreen asFloat / ComponentMax! !

!Color methodsFor: 'access'!
hue
    "Return the hue of this color, an angle in the range [0.0..360.0]."

    | r g b max min span h |
    r _ self privateRed.
    g _ self privateGreen.
    b _ self privateBlue.

    max _ ((r max: g) max: b).
    min _ ((r min: g) min: b).
    span _ (max - min) asFloat.
    span = 0.0 ifTrue: [ ^ 0.0 ].

    r = max ifTrue: [
        h _ ((g - b) asFloat / span) * 60.0.
    ] ifFalse: [
        g = max
            ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ]
            ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ].
    ].

    h < 0.0 ifTrue: [ h _ 360.0 + h ].
    ^ h! !

!Color methodsFor: 'access'!
luminance
    "Return the luminance of this color, a brightness value weighted by the human eye's color sensitivity."

    ^ ((299 * self privateRed) +
       (587 * self privateGreen) +
       (114 * self privateBlue)) / (1000 * ComponentMax)
! !

!Color methodsFor: 'access'!
red
    "Return the red component of this color, a float in the range [0.0..1.0]."

    ^ self privateRed asFloat / ComponentMax! !

!Color methodsFor: 'access'!
saturation
    "Return the saturation of this color, a value between 0.0 and 1.0."

    | r g b max min |
    r _ self privateRed.
    g _ self privateGreen.
    b _ self privateBlue.

    max _ min _ r.
    g > max ifTrue: [max _ g].
    b > max ifTrue: [max _ b].
    g < min ifTrue: [min _ g].
    b < min ifTrue: [min _ b].

    max = 0
        ifTrue: [ ^ 0.0 ]
        ifFalse: [ ^ (max - min) asFloat / max asFloat ].
! !


!Color methodsFor: 'equality' stamp: 'tk 10/21/97 11:24'!
= aColor
    "Return true if the receiver equals the given color. This method handles TranslucentColors, too."

    aColor isColor ifFalse: [^ false].
    aColor isOpaqueMask ifTrue: [^ false].
    aColor isTransparent ifTrue: [^ false].
    ^ aColor privateRGB = rgb and:
        [aColor privateAlpha = self privateAlpha]
! !

!Color methodsFor: 'equality'!
hash

    ^ rgb! !


!Color methodsFor: 'queries' stamp: 'sw 4/25/1998 12:51'!
basicType
    ^ #color! !

!Color methodsFor: 'queries'!
isColor

    ^ true
! !

!Color methodsFor: 'queries'!
isOpaqueMask

    ^ false
! !

!Color methodsFor: 'queries'!
isTransparent

    ^ false
! !


!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
* aNumber
    "Answer this color with its RGB multiplied by the given number. "
    "(Color brown * 2) display"

    ^ Color basicNew
        setPrivateRed: (self privateRed * aNumber) asInteger
        green: (self privateGreen * aNumber) asInteger
        blue: (self privateBlue * aNumber) asInteger
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
+ aColor
    "Answer this color mixed with the given color in an additive color space.  "
    "(Color blue + Color green) display"

    ^ Color basicNew
        setPrivateRed: self privateRed + aColor privateRed
        green: self privateGreen + aColor privateGreen
        blue: self privateBlue + aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'!
- aColor
    "Answer aColor is subtracted from the given color in an additive color space.  "
    "(Color white - Color red) display"

    ^ Color basicNew
        setPrivateRed: self privateRed - aColor privateRed
        green: self privateGreen - aColor privateGreen
        blue: self privateBlue - aColor  privateBlue
! !

!Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'!
/ aNumber
    "Answer this color with its RGB divided by the given number. "
    "(Color red / 2) display"

    ^ Color basicNew
        setPrivateRed: (self privateRed / aNumber) asInteger
        green: (self privateGreen / aNumber) asInteger
        blue: (self privateBlue / aNumber) asInteger
! !

!Color methodsFor: 'transformations'!
alpha: alphaValue
    "Return a new TransparentColor with the given amount of opacity ('alpha')."

    ^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue
! !

!Color methodsFor: 'transformations' stamp: 'di 5/15/1998 21:54'!
dansDarker
    "Return a darker shade of the same color.
    An attempt to do better than the current darker method."
    ^ Color h: self hue s: self saturation
        v: (self brightness - 0.16 max: 0.0)! !

!Color methodsFor: 'transformations'!
darker
    "Return a lighter shade of the same color.  1/6th towards white. 6/18/96 tk  Should this be an absolute step, instead of relative?"
    ^ self mixed: 5/6 with: Color black! !

!Color methodsFor: 'transformations'!
lighter
    "Return a lighter shade of the same color.  1/6th towards white. 6/18/96 tk  Should this be an absolute step, instead of relative?"
    ^ self mixed: 5/6 with: Color white! !

!Color methodsFor: 'transformations'!
mixed: proportion with: aColor
    "Answer this color mixed with the given color. The proportion, a number between 0.0 and 1.0, determines what what fraction of the receiver to use in the mix. For example, 0.9 would yield a color close to the receiver."
    "Details: This method uses RGB interpolation; HSV interpolation can lead to surprises."

    | frac1 frac2 |
    frac1 _ proportion asFloat min: 1.0 max: 0.0.
    frac2 _ 1.0 - frac1.
    ^ Color
        r: (self    red * frac1) + (aColor    red * frac2)
        g: (self green * frac1) + (aColor green * frac2)
        b: (self   blue * frac1) + (aColor  blue * frac2)
! !

!Color methodsFor: 'transformations' stamp: 'jm 9/22/97 15:11'!
muchLighter

    ^ self mixed: 0.233 with: Color white
! !

!Color methodsFor: 'transformations' stamp: 'sw 4/23/1998 18:17'!
veryMuchLighter

    ^ self mixed: 0.1165 with: Color white
! !


!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
darkShades: thisMany
    "An array of thisMany colors from black to the receiver.  Array is of length num. Very useful for displaying color based on a variable in your program.  "
    "Color showColors: (Color red darkShades: 12)"

    ^ self class black mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
lightShades: thisMany
    "An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  "
    "Color showColors: (Color red lightShades: 12)"

    ^ self class white mix: self shades: thisMany
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
mix: color2 shades: thisMany
    "Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program.  "
    "Color showColors: (Color red mix: Color green shades: 12)"

    | redInc greenInc blueInc rr gg bb c out |
    thisMany = 1 ifTrue: [^ Array with: color2].
    redInc _ color2 red - self red / (thisMany-1).
    greenInc _ color2 green - self green / (thisMany-1).
    blueInc _ color2 blue - self blue / (thisMany-1).
    rr _ self red.  gg _ self green.  bb _ self blue.
    out _ (1 to: thisMany) collect: [:num |
        c _ Color r: rr g: gg b: bb.
        rr _ rr + redInc.
        gg _ gg + greenInc.
        bb _ bb + blueInc.
        c].
    out at: out size put: color2.    "hide roundoff errors"
    ^ out
! !

!Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'!
wheel: thisMany
    "An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self.  Array is of length thisMany.  Very useful for displaying color based on a variable in your program.  "

    | sat bri hue step c |
    thisMany = 1 ifTrue: [^ Array with: self].
    sat _ self saturation.
    bri _ self brightness.
    hue _ self hue.
    step _ 360.0 / thisMany.
    ^ (1 to: thisMany) collect: [:num |
        c _ Color h: hue s: sat v: bri.  "hue is taken mod 360"
        hue _ hue + step.
        c].
! !


!Color methodsFor: 'printing'!
printOn: aStream

    self storeOn: aStream.
! !

!Color methodsFor: 'printing'!
shortPrintString
    "Return a short (but less precise) print string for use where space is tight."

    | s |
    s _ WriteStream on: ''.
    s
        nextPutAll: '(' , self class name;
        nextPutAll: ' r: ';
        nextPutAll: (self red roundTo: 0.01) printString;
        nextPutAll: ' g: ';
        nextPutAll: (self green roundTo: 0.01) printString;
        nextPutAll: ' b: ';
        nextPutAll: (self blue roundTo: 0.01) printString;
        nextPutAll: ')'.
    ^ s contents
! !

!Color methodsFor: 'printing'!
storeOn: aStream

    aStream
        nextPutAll: '(' , self class name;
        nextPutAll: ' r: ';
        nextPutAll: (self red roundTo: 0.001) printString;
        nextPutAll: ' g: ';
        nextPutAll: (self green roundTo: 0.001) printString;
        nextPutAll: ' b: ';
        nextPutAll: (self blue roundTo: 0.001) printString;
        nextPutAll: ')'.
! !


!Color methodsFor: 'other' stamp: 'sw 2/16/98 03:42'!
colorForInsets
    ^ self! !

!Color methodsFor: 'other' stamp: 'tk 6/14/96'!
display
    "Show a swatch of this color tracking the cursor until the next mouseClick. "
    "Color red display"
    | f |
    f _ Form extent: 40@20 depth: Display depth.
    f fillColor: self.
    Cursor blank showWhile:
        [f follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:24'!
name
    "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color."

    ColorNames do:
        [:name | (Color perform: name) = self ifTrue: [^ name]].
    ^ nil
! !

!Color methodsFor: 'other' stamp: 'sw 9/17/97 17:27'!
newTileMorphRepresentative
    ^ ColorTileMorph new! !

!Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'!
rgbTriplet
    "Color fromUser rgbTriplet"

    ^ Array
        with: (self red roundTo: 0.01)
        with: (self green roundTo: 0.01)
        with: (self blue roundTo: 0.01)
! !


!Color methodsFor: 'conversions' stamp: 'di 11/3/97 08:40'!
balancedPatternForDepth: depth
    "A generalization of bitPatternForDepth: as it exists.  Generates a 2x2 stipple of color.
    The topLeft and bottomRight pixel are closest approx to this color"
    | pv1 pv2 mask1 mask2 pv3 c |
    depth == cachedDepth ifTrue: [^ cachedBitPattern].
    (depth between: 4 and: 16) ifFalse: [^ self bitPatternForDepth: depth].
    cachedDepth _ depth.
    pv1 _ self pixelValueForDepth: depth.
"
    Subtract error due to pv1 to get pv2.
    pv2 _ (self - (err1 _ (Color colorFromPixelValue: pv1 depth: depth) - self))
                        pixelValueForDepth: depth.
    Subtract error due to 2 pv1's and pv2 to get pv3.
    pv3 _ (self - err1 - err1 - ((Color colorFromPixelValue: pv2 depth: depth) - self))
                        pixelValueForDepth: depth.
"
    "Above two statements computed faster by the following..."
    pv2 _ (c _ self - ((Color colorFromPixelValue: pv1 depth: depth) - self))
                        pixelValueForDepth: depth.
    pv3 _ (c + (c - (Color colorFromPixelValue: pv2 depth: depth)))
                        pixelValueForDepth: depth.

    "Return to a 2-word bitmap that encodes a 2x2 stipple of the given pixelValues."
    mask1 _ (#(- - -
            16r01010101 - - -            "replicates every other 4 bits"
            16r00010001 - - - - - - -    "replicates every other 8 bits"
            16r00000001) at: depth).    "replicates every other 16 bits"
    mask2 _ (#(- - -
            16r10101010 - - -            "replicates the other 4 bits"
            16r01000100 - - - - - - -    "replicates the other 8 bits"
            16r00010000) at: depth).    "replicates the other 16 bits"
    ^ Bitmap with: (mask1*pv1) + (mask2*pv2) with: (mask1*pv3) + (mask2*pv1)! !

!Color methodsFor: 'conversions' stamp: 'tk 6/14/96'!
bitPatternForDepth: depth
    "Return a Bitmap, possibly containing a stipple pattern, that best represents this color at the given depth. BitBlt calls this method to convert colors into Bitmaps. The resulting Bitmap may be multiple words to represent a stipple pattern of several lines.  "
    "See also:    pixelValueAtDepth:    -- value for single pixel
                pixelWordAtDepth:    -- a 32-bit word filled with the pixel value"
    "Details: The pattern for the most recently requested depth is cached."

    depth == cachedDepth ifTrue: [^ cachedBitPattern].
    cachedDepth _ depth.

    depth > 2 ifTrue: [^ cachedBitPattern _ Bitmap with: (self pixelWordForDepth: depth)].
    depth = 1 ifTrue: [^ cachedBitPattern _ self halfTonePattern1].
    depth = 2 ifTrue: [^ cachedBitPattern _ self halfTonePattern2].
! !

!Color methodsFor: 'conversions'!
closestPixelValue1
    "Return the nearest approximation to this color for a monochrome Form."

    "fast special cases"
    rgb = 0 ifTrue: [^ 1].  "black"
    rgb = 16r3FFFFFFF ifTrue: [^ 0].  "white"

    self luminance > 0.5
        ifTrue: [^ 0]  "white"
        ifFalse: [^ 1].  "black"
! !

!Color methodsFor: 'conversions'!
closestPixelValue2
    "Return the nearest approximation to this color for a 2-bit deep Form."

    | lum |
    "fast special cases"
    rgb = 0 ifTrue: [^ 1].  "black"
    rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

    lum _ self luminance.
    lum < 0.2 ifTrue: [^ 1].  "black"
    lum > 0.6 ifTrue: [^ 2].  "opaque white"
    ^ 3  "50% gray"
! !

!Color methodsFor: 'conversions'!
closestPixelValue4
    "Return the nearest approximation to this color for a 4-bit deep Form."

    | bIndex |
    "fast special cases"
    rgb = 0 ifTrue: [^ 1].  "black"
    rgb = 16r3FFFFFFF ifTrue: [^ 2].  "opaque white"

    rgb = PureRed privateRGB ifTrue: [^ 4].
    rgb = PureGreen privateRGB ifTrue: [^ 5].
    rgb = PureBlue privateRGB ifTrue: [^ 6].
    rgb = PureCyan privateRGB ifTrue: [^ 7].
    rgb = PureYellow privateRGB ifTrue: [^ 8].
    rgb = PureMagenta privateRGB ifTrue: [^ 9].

    bIndex _ (self luminance * 8.0) rounded.  "bIndex in [0..8]"
    ^ #(
        1    "black"
        10    "1/8 gray"
        11    "2/8 gray"
        12    "3/8 gray"
        3    "4/8 gray"
        13    "5/8 gray"
        14    "6/8 gray"
        15    "7/8 gray"
        2    "opaque white"
    ) at: bIndex + 1.
! !

!Color methodsFor: 'conversions'!
closestPixelValue8
    "Return the nearest approximation to this color for an 8-bit deep Form."

    "fast special cases"
    rgb = 0 ifTrue: [^ 1].  "black"
    rgb = 16r3FFFFFFF ifTrue: [^ 255].  "white"

    self saturation < 0.2 ifTrue: [
        ^ GrayToIndexMap at: (self privateGreen >> 2) + 1.  "nearest gray"
    ] ifFalse: [
        "compute nearest entry in the color cube"
        ^ 40 +
          ((((self privateRed * 5) + HalfComponentMask) // ComponentMask) * 36) +
          ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) * 6) +
          (((self privateGreen * 5) + HalfComponentMask) // ComponentMask)].
! !

!Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'!
dominantColor
    ^ self! !

!Color methodsFor: 'conversions' stamp: 'di 6/23/97 23:27'!
halfTonePattern1
    "Return a halftone-pattern to approximate luminance levels on 1-bit deep Forms."

    | lum |
    lum _ self luminance.
    lum < 0.1 ifTrue: [^ Bitmap with: 16rFFFFFFFF]. "black"
    lum < 0.4 ifTrue: [^ Bitmap with: 16rBBBBBBBB with: 16rEEEEEEEE]. "dark gray"
    lum < 0.6 ifTrue: [^ Bitmap with: 16r55555555 with: 16rAAAAAAAA]. "medium gray"
    lum < 0.9 ifTrue: [^ Bitmap with: 16r44444444 with: 16r11111111]. "light gray"
    ^ Bitmap with: 0  "1-bit white"
! !

!Color methodsFor: 'conversions'!
halfTonePattern2
    "Return a halftone-pattern to approximate luminance levels on 2-bit deep Forms."

    | lum |
    lum _ self luminance.
    lum < 0.125 ifTrue: [^ Bitmap with: 16r55555555].  "black"
    lum < 0.25 ifTrue: [^ Bitmap with: 16r55555555 with: 16rDDDDDDDD].  "1/8 gray"
    lum < 0.375 ifTrue: [^ Bitmap with: 16rDDDDDDDD with: 16r77777777].  "2/8 gray"
    lum < 0.5 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16r77777777].  "3/8 gray"
    lum < 0.625 ifTrue: [^ Bitmap with: 16rFFFFFFFF].  "4/8 gray"
    lum < 0.75 ifTrue: [^ Bitmap with: 16rFFFFFFFF with: 16rBBBBBBBB].  "5/8 gray"
    lum < 0.875 ifTrue: [^ Bitmap with: 16rEEEEEEEE with: 16rBBBBBBBB].  "6/8 gray"
    lum < 1.0 ifTrue: [^ Bitmap with: 16rAAAAAAAA with: 16rBBBBBBBB].  "7/8 gray"
    ^ Bitmap with: 16rAAAAAAAA  "opaque white"

"handy expression for computing patterns for 2x2 tiles;
 set p to a string of 4 letters (e.g., 'wggw' for a gray-and-
 white checkerboard) and print the result of evaluating:
| p d w1 w2 |
p _ 'wggw'.
d _ Dictionary new.
d at: $b put: '01'.
d at: $w put: '10'.
d at: $g put: '11'.
w1 _ (d at: (p at: 1)), (d at: (p at: 2)).
w1 _ '2r', w1, w1, w1, w1, w1, w1, w1, w1, ' hex'.
w2 _ (d at: (p at: 3)), (d at: (p at: 4)).
w2 _ '2r', w2, w2, w2, w2, w2, w2, w2, w2, ' hex'.
Array with: (Compiler evaluate: w1) with: (Compiler evaluate: w2)
"! !

!Color methodsFor: 'conversions' stamp: 'tk 4/24/97'!
indexInMap: aColorMap
    "Return the index corresponding to this color in the given color map. RGB colors are truncated to 3-, 4-, or 5-bits per color component when indexing into such a colorMap.  "

    aColorMap size = 2 ifTrue: [^ (self pixelValueForDepth: 1) + 1].
    aColorMap size = 4 ifTrue: [^ (self pixelValueForDepth: 2) + 1].
    aColorMap size = 16 ifTrue: [^ (self pixelValueForDepth: 4) + 1].
    aColorMap size = 256 ifTrue: [^ (self pixelValueForDepth: 8) + 1].
    aColorMap size = 512 ifTrue: [^ (self pixelValueForDepth: 9) + 1].
    aColorMap size = 4096 ifTrue: [^ (self pixelValueForDepth: 12) + 1].
    aColorMap size = 32768 ifTrue: [^ (self pixelValueForDepth: 16) + 1].
    self error: 'unknown pixel depth'.
! !

!Color methodsFor: 'conversions'!
pixelValueForDepth: d
    "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:"
    "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component."
    "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue."

    | rgbBlack val |
    d = 8 ifTrue: [^ self closestPixelValue8].  "common case"
    d < 8 ifTrue: [
        d = 4 ifTrue: [^ self closestPixelValue4].
        d = 2 ifTrue: [^ self closestPixelValue2].
        d = 1 ifTrue: [^ self closestPixelValue1]].

    rgbBlack _ 1.  "closest black that is not transparent in RGB"

    d = 16 ifTrue: [
        "five bits per component; top bits ignored"
        val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr:
             ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr:
             ((rgb bitShift: -5) bitAnd: 16r001F).
        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

    d = 32 ifTrue: [
        "eight bits per component; top 8 bits ignored"
        val _ (((rgb bitShift: -6) bitAnd: 16rFF0000) bitOr:
             ((rgb bitShift: -4) bitAnd: 16r00FF00)) bitOr:
             ((rgb bitShift: -2) bitAnd: 16r0000FF).
        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

    d = 12 ifTrue: [  "for indexing a color map with 4 bits per color component"
        val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr:
             ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr:
             ((rgb bitShift: -6) bitAnd: 16r000F).
        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

    d = 9 ifTrue: [  "for indexing a color map with 3 bits per color component"
        val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr:
             ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr:
             ((rgb bitShift: -7) bitAnd: 16r0007).
        ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]].

    self error: 'unknown pixel depth: ', d printString
! !

!Color methodsFor: 'conversions'!
pixelWordFor: depth filledWith: pixelValue
    "Return to a 32-bit word that concatenates enough copies of the given pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."

    depth = 32 ifTrue: [^ pixelValue].
    ^ (pixelValue bitAnd: (1 bitShift: depth) - 1) *
        (#(16rFFFFFFFF                "replicates at every bit"
            16r55555555 -            "replicates every 2 bits"
            16r11111111 - - -            "replicates every 4 bits"
            16r01010101 - - - - - - -    "replicates every 8 bits"
            16r00010001) at: depth)    "replicates every 16 bits"
! !

!Color methodsFor: 'conversions'!
pixelWordForDepth: depth
    "Return to a 32-bit word that concatenates enough copies of the receiver's pixel value to fill the word (i.e., 32/depth copies). Depth should be one of 1, 2, 4, 8, 16, or 32. The pixel value should be an integer in 0..2^depth-1."

    | pixelValue |
    pixelValue _ self pixelValueForDepth: depth.
    ^ self pixelWordFor: depth filledWith: pixelValue
! !


!Color methodsFor: 'private'!
attemptToMutateError
    "A color is immutable. Once a color's red, green, and blue have been initialized, you cannot change them. Instead, create a new Color and use it."

    self error: 'Color objects are immutable once created'
! !

!Color methodsFor: 'private'!
flushCache
    "Flush my cached bit pattern."

    cachedDepth _ nil.
    cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
privateAlpha
    "Private!! Return the raw alpha value for opaque. Used only for equality testing."

    ^ 255! !

!Color methodsFor: 'private'!
privateBlue
    "Private!! Return the internal representation of my blue component."

    ^ rgb bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateGreen
    "Private!! Return the internal representation of my green component."

    ^ (rgb >> GreenShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateRed
    "Private!! Return the internal representation of my red component."

    ^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! !

!Color methodsFor: 'private'!
privateRGB
    "Private!! Return the internal representation of my RGB components."

    ^ rgb
! !

!Color methodsFor: 'private'!
setHue: hue saturation: saturation brightness: brightness
    "Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."

    | s v hf i f p q t |
    s _ (saturation asFloat max: 0.0) min: 1.0.
    v _ (brightness asFloat max: 0.0) min: 1.0.

    "zero saturation yields gray with the given brightness"
    s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ].

    hf _ hue asFloat.
    (hf < 0.0 or: [hf >= 360.0])
        ifTrue: [hf _ hf - ((hf quo: 360.0) asFloat * 360.0)].
    hf _ hf / 60.0.
    i _ hf asInteger.  "integer part of hue"
    f _ hf fractionPart.         "fractional part of hue"
    p _ (1.0 - s) * v.
    q _ (1.0 - (s * f)) * v.
    t _ (1.0 - (s * (1.0 - f))) * v.

    0 = i ifTrue: [ ^ self setRed: v green: t blue: p ].
    1 = i ifTrue: [ ^ self setRed: q green: v blue: p ].
    2 = i ifTrue: [ ^ self setRed: p green: v blue: t ].
    3 = i ifTrue: [ ^ self setRed: p green: q blue: v ].
    4 = i ifTrue: [ ^ self setRed: t green: p blue: v ].
    5 = i ifTrue: [ ^ self setRed: v green: p blue: q ].

    self error: 'implementation error'.
! !

!Color methodsFor: 'private' stamp: 'di 11/2/97 12:19'!
setPrivateRed: r green: g blue: b
    "Initialize this color's r, g, and b components to the given values in the range [0..ComponentMax].  Encoded in a single variable as 3 integers in [0..1023]."

    rgb == nil ifFalse: [self attemptToMutateError].
    rgb _ ((r min: ComponentMask max: 0) bitShift: RedShift) +
        ((g min: ComponentMask max: 0) bitShift: GreenShift) +
         (b min: ComponentMask max: 0).
    cachedDepth _ nil.
    cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b
    "Initialize this color's r, g, and b components to the given values in the range [0.0..1.0].  Encoded in a single variable as 3 integers in [0..1023]."

    rgb == nil ifFalse: [self attemptToMutateError].
    rgb _
        (((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +
        (((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +
         ((b * ComponentMax) rounded bitAnd: ComponentMask).
    cachedDepth _ nil.
    cachedBitPattern _ nil.
! !

!Color methodsFor: 'private'!
setRed: r green: g blue: b range: range
    "Initialize this color's r, g, and b components to the given values in the range [0..r]."

    rgb == nil ifFalse: [self attemptToMutateError].
    rgb _
        ((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +
        ((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +
         (((b * ComponentMask) // range) bitAnd: ComponentMask).
    cachedDepth _ nil.
    cachedBitPattern _ nil.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Color class
    instanceVariableNames: ''!

!Color class methodsFor: 'instance creation' stamp: 'jm 12/1/97 20:43'!
colorFromPixelValue: p depth: d
    "Convert a pixel value for the given display depth into a color."
    "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color."

    | r g b alpha |
    d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1].
    d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1].
    d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1].
    d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1].

    (d = 16) | (d = 15) ifTrue: [
        "five bits per component"
        r _ (p bitShift: -10) bitAnd: 16r1F.
        g _ (p bitShift: -5) bitAnd: 16r1F.
        b _ p bitAnd: 16r1F.
        ^ Color r: r g: g b: b range: 31].

    d = 32 ifTrue: [
        "eight bits per component; 8 bits of alpha"
        r _ (p bitShift: -16) bitAnd: 16rFF.
        g _ (p bitShift: -8) bitAnd: 16rFF.
        b _ p bitAnd: 16rFF.
        alpha _ p bitShift: -24.
        alpha > 0
            ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)]
            ifFalse: [^ (Color r: r g: g b: b range: 255)]].

    d = 12 ifTrue: [
        "four bits per component"
        r _ (p bitShift: -8) bitAnd: 16rF.
        g _ (p bitShift: -4) bitAnd: 16rF.
        b _ p bitAnd: 16rF.
        ^ Color r: r g: g b: b range: 15].

    d = 9 ifTrue: [
        "three bits per component"
        r _ (p bitShift: -6) bitAnd: 16r7.
        g _ (p bitShift: -3) bitAnd: 16r7.
        b _ p bitAnd: 16r7.
        ^ Color r: r g: g b: b range: 7].

    self error: 'unknown pixel depth: ', d printString
! !

!Color class methodsFor: 'instance creation' stamp: 'sw 8/8/97 22:03'!
fromRgbTriplet: list
    ^ self r: list first g: list second b: list last! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'!
gray: brightness
    "Return a gray shade with the given brightness in the range [0.0..1.0]."

    ^ self basicNew setRed: brightness green: brightness blue: brightness
! !

!Color class methodsFor: 'instance creation'!
h: hue s: saturation v: brightness
    "Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example, (Color h: 0 s: 1 v: 1) is pure red."
    "Note: By convention, brightness is abbreviated 'v' to to avoid confusion with blue."

    ^ self basicNew setHue: hue saturation: saturation brightness: brightness! !

!Color class methodsFor: 'instance creation'!
new

    ^ self r: 0.0 g: 0.0 b: 0.0! !

!Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:04'!
r: r g: g b: b
    "Return a color with the given r, g, and b components in the range [0.0..1.0]."

    ^ self basicNew setRed: r green: g blue: b
! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b alpha: alpha

    ^ (self r: r g: g b: b) alpha: alpha! !

!Color class methodsFor: 'instance creation'!
r: r g: g b: b range: range
    "Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."

    ^ self basicNew setRed: r green: g blue: b range: range! !

!Color class methodsFor: 'instance creation'!
random
    "Return a random color that isn't too dark or under-saturated."

    ^ self basicNew
        setHue: (360.0 * RandomStream next)
        saturation: (0.3 + (RandomStream next * 0.7))
        brightness: (0.4 + (RandomStream next * 0.6))! !


!Color class methodsFor: 'class initialization'!
initialize
    "Color initialize"

    "Details: Externally, the red, green, and blue components of color
    are floats in the range [0.0..1.0]. Internally, they are represented
    as integers in the range [0..ComponentMask] packing into a
    small integer to save space and to allow fast hashing and
    equality testing.

    For a general description of color representations for computer
    graphics, including the relationship between the RGB and HSV
    color models used here, see Chapter 17 of Foley and van Dam,
    Fundamentals of Interactive Computer Graphics, Addison-Wesley,
    1982."

    ComponentMask _ 1023.
    HalfComponentMask _ 512.  "used to round up in integer calculations"
    ComponentMax _ 1023.0.  "a Float used to normalize components"
    RedShift _ 20.
    GreenShift _ 10.
    BlueShift _ 0.

    PureRed         _ self r: 1 g: 0 b: 0.
    PureGreen     _ self r: 0 g: 1 b: 0.
    PureBlue     _ self r: 0 g: 0 b: 1.
    PureYellow     _ self r: 1 g: 1 b: 0.
    PureCyan     _ self r: 0 g: 1 b: 1.
    PureMagenta _ self r: 1 g: 0 b: 1.

    RandomStream _ Random new.

    self initializeIndexedColors.
    self initializeGrayToIndexMap.
    self initializeNames.
    self initializeHighLights.
! !

!Color class methodsFor: 'class initialization'!
initializeGrayToIndexMap
    "Build an array of gray values available in the 8-bit colormap. This array is indexed by a gray level between black (1) and white (256) and returns the pixel value for the corresponding gray level."
    "Note: This method must be called after initializeIndexedColors, since it uses IndexedColors."
    "Color initializeGrayToIndexMap"

    | grayLevels grayIndices c distToClosest dist indexOfClosest |
    "record the level and index of each gray in the 8-bit color table"
    grayLevels _ OrderedCollection new.
    grayIndices _ OrderedCollection new.
    "Note: skip the first entry, which is reserved for transparent"
    2 to: IndexedColors size do: [:i |
        c _ IndexedColors at: i.
        c saturation = 0.0 ifTrue: [  "c is a gray"
            grayLevels add: (c privateBlue) >> 2.  "top 8 bits; R, G, and B are the same"
            grayIndices add: i - 1]].  "pixel values are zero-based"
    grayLevels _ grayLevels asArray.
    grayIndices _ grayIndices asArray.

    "for each gray level in [0..255], select the closest match"
    GrayToIndexMap _ ByteArray new: 256.
    0 to: 255 do: [:level |
        distToClosest _ 10000.  "greater than distance to any real gray"
        1 to: grayLevels size do: [:i |
            dist _ (level - (grayLevels at: i)) abs.
            dist < distToClosest ifTrue: [
                distToClosest _ dist.
                indexOfClosest _ grayIndices at: i]].
        GrayToIndexMap at: (level + 1) put: indexOfClosest].
! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/22/96'!
initializeHighLights
    "Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. "
    "Color initializeHighLights"

    | t |
    t _ Array new: 32.
    t at: 1 put: (Bitmap with: 16rFFFFFFFF).
    t at: 2 put: (Bitmap with: 16rFFFFFFFF).
    t at: 4 put: (Bitmap with: 16r55555555).
    t at: 8 put: (Bitmap with: 16r7070707).
    t at: 16 put: (Bitmap with: 16rFFFFFFFF).
    t at: 32 put: (Bitmap with: 16rFFFFFFFF).
    HighLightBitmaps _ t.
! !

!Color class methodsFor: 'class initialization'!
initializeIndexedColors
    "Build an array of colors corresponding to the fixed colormap used
     for display depths of 1, 2, 4, or 8 bits."
    "Color initializeIndexedColors"

    | a index grayVal |
    a _ Array new: 256.

    "1-bit colors (monochrome)"
    a at: 1 put: (Color r: 1.0 g: 1.0 b: 1.0).        "white or transparent"
    a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0).    "black"

    "additional colors for 2-bit color"
    a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0).    "opaque white"
    a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5).    "1/2 gray"

    "additional colors for 4-bit color"
    a at:  5 put: (Color r: 1.0 g: 0.0 b: 0.0).    "red"
    a at:  6 put: (Color r: 0.0 g: 1.0 b: 0.0).    "green"
    a at:  7 put: (Color r: 0.0 g: 0.0 b: 1.0).    "blue"
    a at:  8 put: (Color r: 0.0 g: 1.0 b: 1.0).    "cyan"
    a at:  9 put: (Color r: 1.0 g: 1.0 b: 0.0).    "yellow"
    a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0).    "magenta"

    a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125).        "1/8 gray"
    a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25).        "2/8 gray"
    a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375).        "3/8 gray"
    a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625).        "5/8 gray"
    a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75).        "6/8 gray"
    a at: 16 put: (Color r: 0.875 g: 0.875 b: 0.875).        "7/8 gray"

    "additional colors for 8-bit color"
    "24 more shades of gray (1/32 increments but not repeating 1/8 increments)"
    index _ 17.
    1 to: 31 do: [:v |
        (v \\ 4) = 0 ifFalse: [
            grayVal _ v / 32.0.
            a at: index put: (Color r: grayVal g: grayVal b: grayVal).
            index _ index + 1]].

    "The remainder of color table defines a color cube with six steps
     for each primary color. Note that the corners of this cube repeat
     previous colors, but this simplifies the mapping between RGB colors
     and color map indices. This color cube spans indices 40 through 255
     (indices 41-256 in this 1-based array)."
    0 to: 5 do: [:r |
        0 to: 5 do: [:g |
            0 to: 5 do: [:b |
                index _ 41 + ((36 * r) + (6 * b) + g).
                index > 256 ifTrue: [
                    self error: 'index out of range in color table compuation'].
                a at: index put: (Color r: r g: g b: b range: 5)]]].

    IndexedColors _ a.
! !

!Color class methodsFor: 'class initialization'!
initializeNames
    "Name some colors."
    "Color initializeNames"

    ColorNames _ OrderedCollection new.
    self named: #black put: (Color r: 0 g: 0 b: 0).
    self named: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125).
    self named: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25).
    self named: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375).
    self named: #gray put: (Color r: 0.5 g: 0.5 b: 0.5).
    self named: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625).
    self named: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75).
    self named: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875).
    self named: #white put: (Color r: 1.0 g: 1.0 b: 1.0).
    self named: #red put: (Color r: 1.0 g: 0 b: 0).
    self named: #yellow put: (Color r: 1.0 g: 1.0 b: 0).
    self named: #green put: (Color r: 0 g: 1.0 b: 0).
    self named: #cyan put: (Color r: 0 g: 1.0 b: 1.0).
    self named: #blue put: (Color r: 0 g: 0 b: 1.0).
    self named: #magenta put: (Color r: 1.0 g: 0 b: 1.0).
    self named: #brown put: (Color r: 0.6 g: 0.2 b: 0).
    self named: #orange put: (Color r: 1.0 g: 0.6 b: 0).
    self named: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8).
    self named: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8).
    self named: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6).
    self named: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0).
    self named: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0).
    self named: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0).
    self named: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2).
    self named: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4).
    self named: #transparent put: (TransparentColor new).
    self named: #opaqueMask put: (OpaqueMaskColor new).
! !

!Color class methodsFor: 'class initialization' stamp: 'tk 6/13/96'!
named: newName put: aColor
    "Add a new color to the list and create an access message and a class variable for it.  The name should start with a lowercase letter.  (The class variable will start with an uppercase letter.)  (Color colorNames) returns a list of all color names.  "
    | str cap sym accessor csym |
    (aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].
    str _ newName asString.
    sym _ str asSymbol.
    cap _ str capitalized.
    csym _ cap asSymbol.
    (self class canUnderstand: sym) ifFalse: [
        "define access message"
        accessor _ str, (String with: Character cr with: Character tab),             '^', cap.
        self class compile: accessor
            classified: 'named colors'].
    (self classPool includesKey: csym) ifFalse: [
        self addClassVarName: cap].
    (ColorNames includes: sym) ifFalse: [
        ColorNames add: sym].
    ^ self classPool at: csym put: aColor! !


!Color class methodsFor: 'examples'!
colorRampForDepth: depth extent: aPoint
    "Returns a form of the given size showing R, G, B, and gray ramps for the given depth. Useful for testing color conversions between different depths."
    "(Color colorRampForDepth: Display depth extent: 256@80) display"
    "(Color colorRampForDepth: 32 extent: 256@80) displayOn: Display at: 0@0 rule: Form paint"

    | f dx dy r |
    f _ Form extent: aPoint depth: depth.
    dx _ aPoint x // 256.
    dy _ aPoint y // 4.
    0 to: 255 do: [:i |
        r _ (dx * i)@0 extent: dx@dy.
        f fill: r fillColor: (Color r: i g: 0 b: 0 range: 255).
        r _ r translateBy: 0@dy.
        f fill: r fillColor: (Color r: 0 g: i b: 0 range: 255).
        r _ r translateBy: 0@dy.
        f fill: r fillColor: (Color r: 0 g: 0 b: i range: 255).
        r _ r translateBy: 0@dy.
        f fill: r fillColor: (Color r: i g: i b: i range: 255)].
    ^ f
! !

!Color class methodsFor: 'examples' stamp: 'tk 6/19/96'!
hotColdShades: thisMany
    "An array of thisMany colors showing temperature from blue to red to white hot.  (Later improve this by swinging in hue.)  "
    "Color showColors: (Color hotColdShades: 25)"

    | n s1 s2 s3 s4 s5 |
    thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades'].
    n _ thisMany // 5.
    s1 _ self white mix: self yellow shades: (thisMany - (n*4)).
    s2 _ self yellow mix: self red shades: n+1.
    s2 _ s2 copyFrom: 2 to: n+1.
    s3 _ self red mix: self green darker shades: n+1.
    s3 _ s3 copyFrom: 2 to: n+1.
    s4 _ self green darker mix: self blue shades: n+1.
    s4 _ s4 copyFrom: 2 to: n+1.
    s5 _ self blue mix: self black shades: n+1.
    s5 _ s5 copyFrom: 2 to: n+1.
    ^ s1, s2, s3, s4, s5
! !

!Color class methodsFor: 'examples'!
showColorCube
    "Show a 12x12x12 color cube."
    "Color showColorCube"

    0 to: 11 do: [:r |
        0 to: 11 do: [:g |
            0 to: 11 do: [:b |
                Display fill: (((r*60) + (b*5)) @ (g*5) extent: 5@5)
                    fillColor: (Color r: r g: g b: b range: 11)]]].
! !

!Color class methodsFor: 'examples'!
showColors: colorList
    "Display the given collection of colors across the top of the Display."

    | w r |
    w _ Display width // colorList size.
    r _ 0@0 extent: w@((w min: 30) max: 10).
    colorList do: [:c |
        Display fill: r fillColor: c.
        r _ r translateBy: w@0].
! !

!Color class methodsFor: 'examples'!
showHSVPalettes
    "Shows a palette of hues, varying the saturation and brightness for each one. Best results are with depths 16 and 32."
    "Color showHSVPalettes"

    | left top c |
    left _ top _ 0.
    0 to: 179 by: 15 do: [:h |
        0 to: 10 do: [:s |
            left _ (h * 4) + (s * 4).
            0 to: 10 do: [:v |
                c _ Color h: h s: s asFloat / 10.0 v: v asFloat / 10.0.
                top _ (v * 4).
                Display fill: (left@top extent: 4@4) fillColor: c.

                c _ Color h: h + 180 s: s asFloat / 10.0 v: v asFloat / 10.0.
                top _ (v * 4) + 50.
                Display fill: (left@top extent: 4@4) fillColor: c]]].
! !

!Color class methodsFor: 'examples'!
showHuesInteractively
    "Shows a palette of hues at a (saturation, brightness) point determined by the mouse position. Click the mouse button to exit and return the selected (saturation, brightness) point."
    "Color showHuesInteractively"

    | p s v |
    [Sensor anyButtonPressed] whileFalse: [
        p _ Sensor cursorPoint.
        s _ p x asFloat / 300.0.
        v _ p y asFloat / 300.0.
        self showColors: (self wheel: 12 saturation: s brightness: v)].
    ^ (s min: 1.0) @ (v min: 1.0)! !

!Color class methodsFor: 'examples'!
wheel: thisMany
    "Return a collection of thisMany colors evenly spaced around the color wheel."
    "Color showColors: (Color wheel: 12)"

    ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7
! !

!Color class methodsFor: 'examples'!
wheel: thisMany saturation: s brightness: v
    "Return a collection of thisMany colors evenly spaced around the color wheel, all of the given saturation and brightness."
    "Color showColors: (Color wheel: 12 saturation: 0.4 brightness: 1.0)"
    "Color showColors: (Color wheel: 12 saturation: 0.8 brightness: 0.5)"

    ^ (Color h: 0.0 s: s v: v) wheel: thisMany
! !


!Color class methodsFor: 'named colors'!
black
    ^Black! !

!Color class methodsFor: 'named colors'!
blue
    ^Blue! !

!Color class methodsFor: 'named colors'!
brown
    ^Brown! !

!Color class methodsFor: 'named colors'!
cyan
    ^Cyan! !

!Color class methodsFor: 'named colors'!
darkGray
    ^DarkGray! !

!Color class methodsFor: 'named colors'!
gray
    ^Gray! !

!Color class methodsFor: 'named colors'!
green
    ^Green! !

!Color class methodsFor: 'named colors'!
lightBlue
    ^LightBlue! !

!Color class methodsFor: 'named colors'!
lightBrown
    ^LightBrown! !

!Color class methodsFor: 'named colors'!
lightCyan
    ^LightCyan! !

!Color class methodsFor: 'named colors'!
lightGray
    ^LightGray! !

!Color class methodsFor: 'named colors'!
lightGreen
    ^LightGreen! !

!Color class methodsFor: 'named colors'!
lightMagenta
    ^LightMagenta! !

!Color class methodsFor: 'named colors'!
lightOrange
    ^LightOrange! !

!Color class methodsFor: 'named colors'!
lightRed
    ^LightRed! !

!Color class methodsFor: 'named colors'!
lightYellow
    ^LightYellow! !

!Color class methodsFor: 'named colors'!
magenta
    ^Magenta! !

!Color class methodsFor: 'named colors'!
opaqueMask
    ^OpaqueMask! !

!Color class methodsFor: 'named colors'!
orange
    ^Orange! !

!Color class methodsFor: 'named colors'!
red
    ^Red! !

!Color class methodsFor: 'named colors'!
transparent
    ^Transparent! !

!Color class methodsFor: 'named colors'!
veryDarkGray
    ^VeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryLightGray
    ^VeryLightGray! !

!Color class methodsFor: 'named colors'!
veryVeryDarkGray
    ^VeryVeryDarkGray! !

!Color class methodsFor: 'named colors'!
veryVeryLightGray
    ^VeryVeryLightGray! !

!Color class methodsFor: 'named colors'!
white
    ^White! !

!Color class methodsFor: 'named colors'!
yellow
    ^Yellow! !


!Color class methodsFor: 'colormaps' stamp: 'jm 11/12/97 19:16'!
cachedColormapFrom: sourceDepth to: destDepth
    "Return a cached colormap for mapping between the given depths. Always return a real colormap, not nil; this allows the client to get an identity colormap that can then be copied and modified to do color transformations."
    "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"
    "Note: The colormap cache may be cleared by evaluating 'Color shutDown'."

    | key newMap |
    key _ sourceDepth@destDepth.
    CachedColormaps == nil ifTrue: [CachedColormaps _ Dictionary new].
    ^ CachedColormaps at: key ifAbsent: [
        newMap _ self computeColormapFrom: sourceDepth to: destDepth.
        CachedColormaps at: key put: newMap.
        ((sourceDepth >= 16) and: [destDepth < 16]) ifTrue: [
            "can use the same map from both 16-bits and 32-bits to a given lesser depth"
            CachedColormaps at: 16@destDepth put: newMap.
            CachedColormaps at: 32@destDepth put: newMap].
        newMap].
! !

!Color class methodsFor: 'colormaps'!
colorMapIfNeededFrom: sourceDepth to: destDepth
    "Return a colormap for mapping between the given depths, or nil if no colormap is needed."
    "Note: This method returns a shared, cached colormap to save time and space. Clients that need to modify a colormap returned by this method should make a copy and modify that!!"

    sourceDepth = destDepth ifTrue: [^ nil].  "not needed if depths are the same"

    (sourceDepth >= 16) & (destDepth >= 16) ifTrue: [
        "mapping is done in BitBlt by zero-filling or truncating each color component"
        ^ nil].

    ^ Color cachedColormapFrom: sourceDepth to: destDepth
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 12/5/97 18:27'!
computeColormapFrom: sourceDepth to: destDepth
    "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead."

    | map |
    sourceDepth < 16 ifTrue: [
        "source is 1-, 2-, 4-, or 8-bit indexed color"
        map _ (IndexedColors copyFrom: 1 to: (1 bitShift: sourceDepth))
                    collect: [:c | c pixelValueForDepth: destDepth].
        map _ map as: Bitmap.
    ] ifFalse: [
        "source is 16-bit or 32-bit RGB; use colormap with 4 bits per color component"
        map _ self computeRGBColormapFor: destDepth bitsPerColor: 4].

    "Note: zero is transparent except when source depth is one-bit deep"
    sourceDepth > 1 ifTrue: [map at: 1 put: 0].
    ^ map
! !

!Color class methodsFor: 'colormaps' stamp: 'jm 12/4/97 15:25'!
computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor
    "Compute a colorMap for translating from 16-bit or 32-bit RGB color to the given depth, using the given number of of bits per color component."

    | mask map c |
    (#(3 4 5) includes: bitsPerColor)
        ifFalse: [self error: 'BitBlt only supports 3, 4, or 5 bits per color component'].
    mask _ (1 bitShift: bitsPerColor) - 1.
    map _ Bitmap new: (1 bitShift: (3 * bitsPerColor)).
    0 to: map size - 1 do: [:i |
        c _ Color
            r: ((i bitShift: 0 - (2 * bitsPerColor)) bitAnd: mask)
            g: ((i bitShift: 0 - bitsPerColor) bitAnd: mask)
            b: ((i bitShift: 0) bitAnd: mask)
            range: mask.
        map at: i + 1 put: (c pixelValueForDepth: destDepth)].

    map at: 1 put: (Color transparent pixelWordForDepth: destDepth).  "zero always transparent"
    ^ map
! !


!Color class methodsFor: 'other'!
colorNames
    "Return a collection of color names."

    ^ ColorNames! !

!Color class methodsFor: 'other'!
indexedColors

    ^ IndexedColors! !

!Color class methodsFor: 'other'!
maskingMap: depth
    "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero. Cache the most recently used map."

    | sizeNeeded |
    depth <= 8
        ifTrue: [sizeNeeded _ 1 bitShift: depth]
        ifFalse: [sizeNeeded _ 4096].
    MaskingMap size = sizeNeeded ifTrue: [^ MaskingMap].

    MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF.
    MaskingMap at: 1 put: 0.  "transparent"

    ^ MaskingMap
! !

!Color class methodsFor: 'other'!
pixelScreenForDepth: depth
    "Return a 50% stipple containing alternating pixels of all-zeros and all-ones to be used as a mask at the given depth."

    | mask bits |
    mask _ (1 bitShift: depth) - 1.
    bits _ 2 * depth.
    [bits >= 32] whileFalse: [
        mask _ mask bitOr: (mask bitShift: bits).  "double the length of mask"
        bits _ bits + bits].
    ^ Bitmap with: mask with: mask bitInvert32
! !

!Color class methodsFor: 'other'!
quickHighLight: depth
    "Quickly return a Bitblt-ready raw colorValue for highlighting areas.  6/22/96 tk"

    ^ HighLightBitmaps at: depth! !

!Color class methodsFor: 'other'!
shutDown
    "Color shutDown"

    ColorChart _ nil.        "Palette of colors for the user to pick from"
    CachedColormaps _ nil.    "Maps to translate between color depths"
    MaskingMap _ nil.        "Maps all colors except transparent to black for creating a mask"
! !


!Color class methodsFor: 'color from user' stamp: 'jm 12/5/97 18:35'!
colorPaletteForDepth: depth extent: chartExtent
    "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
    "Note: It is slow to build this palette, so it should be cached for quick access."
    "(Color colorPaletteForDepth: 16 extent: 190@60) display"

    | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
    palette _ Form extent: chartExtent depth: depth.
    transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
        (Form extent: 34@9 depth: 1
            fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
            offset: 0@0).
    transHt _ transCaption height.
    palette fillWhite: (0@0 extent: palette width@transHt).
    palette fillBlack: (0@transHt extent: palette width@1).
    transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
    grayWidth _ 10.
    startHue _ 338.0.
    vSteps _ palette height - transHt // 2.
    hSteps _ palette width - grayWidth.
    x _ 0.
    startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
        basicHue _ Color h: h asFloat s: 1.0 v: 1.0.
        y _ transHt+1.
        0 to: vSteps do: [:n |
             c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
            palette fill: (x@y extent: 1@1) fillColor: c.
            y _ y + 1].
        1 to: vSteps do: [:n |
             c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
            palette fill: (x@y extent: 1@1) fillColor: c.
            y _ y + 1].
        x _ x + 1].
    y _ transHt + 1.
    1 to: vSteps * 2 do: [:n |
         c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
        palette fill: (x@y extent: 10@1) fillColor: c.
        y _ y + 1].
    ^ palette
! !

!Color class methodsFor: 'color from user' stamp: 'jm 12/4/97 10:32'!
fromUser
    "Displays a color palette of colors, waits for a mouse click, and returns the selected color. Any pixel on the Display can be chosen, not just those in the color palette."
    "Note: Since the color chart is cached, you may need to do 'ColorChart _ nil' after changing the oldColorPaletteForDepth:extent: method."
    "Color fromUser"

    | d startPt save tr oldColor c here s |
    d _ Display depth.
    ((ColorChart == nil) or: [ColorChart depth ~= Display depth])
        ifTrue: [ColorChart _ self oldColorPaletteForDepth: d extent: (2 * 144)@80].
    Sensor cursorPoint y < Display center y
        ifTrue: [startPt _ 0@(Display boundingBox bottom - ColorChart height)]
        ifFalse: [startPt _ 0@0].

    save _ Form fromDisplay: (startPt extent: ColorChart extent).
    ColorChart displayAt: startPt.
    tr _ ColorChart extent - (50@19) corner: ColorChart extent.
    tr _ tr translateBy: startPt.

    oldColor _ nil.
    [Sensor anyButtonPressed] whileFalse: [
        c _ Display colorAt: (here _ Sensor cursorPoint).
        (tr containsPoint: here)
            ifFalse: [Display fill: (0@61+startPt extent: 20@19) fillColor: c]
            ifTrue: [
                c _ Color transparent.
                Display fill: (0@61+startPt extent: 20@19) fillColor: Color white].
        c = oldColor ifFalse: [
            Display fillWhite: (20@61 + startPt extent: 135@19).
            c isTransparent
                ifTrue: [s _ c shortPrintString]
                ifFalse: [
                    s _ c shortPrintString.
                    s _ s copyFrom: 7 to: s size - 1].
            s displayAt: 20@61 + startPt.
            oldColor _ c]].
    save displayAt: startPt.
    Sensor waitNoButton.
    ^ c
! !

!Color class methodsFor: 'color from user' stamp: 'jm 12/5/97 18:34'!
oldColorPaletteForDepth: depth extent: paletteExtent
    "Returns a form of the given size showing a color palette for the given depth."
    "(Color oldColorPaletteForDepth: Display depth extent: 720@100) display"

    | c p f nSteps rect w h q |
    f _ Form extent: paletteExtent depth: depth.
    f fill: f boundingBox fillColor: Color white.
    nSteps _ depth > 8 ifTrue: [12] ifFalse: [6].
    w _ paletteExtent x // (nSteps * nSteps).
    h _ paletteExtent y - 20 // nSteps.
    0 to: nSteps-1 do: [:r |
        0 to: nSteps-1 do: [:g |
            0 to: nSteps-1 do: [:b |
                c _ Color r: r g: g b: b range: nSteps - 1.
                rect _ ((r * nSteps * w) + (b * w)) @ (g * h) extent: w@(h + 1).
                f fill: rect fillColor: c]]].
    q _ Quadrangle origin: paletteExtent - (50@19) corner: paletteExtent.
    q displayOn: f.
    ('Trans.' asParagraph asForm) displayOn: f at: q origin + (9@0) rule: Form paint.

    w _ ((paletteExtent x - q width - 130) // 64) max: 1.
    p _ paletteExtent x - q width - (64 * w) - 1 @ (paletteExtent y - 19).
    0 to: 63 do:
        [:v | c _ Color r: v g: v b: v range: 63.
        f fill: ((v * w)@0 + p extent: (w + 1)@19) fillColor: c].
    ^ f
! !
Form subclass: #ColorForm
    instanceVariableNames: 'colors cachedDepth cachedColormap '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Display Objects'!
!ColorForm commentStamp: 'di 5/22/1998 16:32' prior: 0!
ColorForm is a normal Form plus a color map of up to 2^depth Colors. Typically, one reserves one entry in the color map for transparent. This allows 1, 3, 15, or 255 non-transparent colors in ColorForms of depths 1, 2, 4, and 8 bits per pixel. ColorForms don't support depths greater than 8 bits because that would require excessively large color maps with little real benefit, since 16-bit and 32-bit depths already support thousands and millions of colors.

ColorForms have several uses:
  1) Precise colors. You can have up to 256 true colors, instead being limited to the 8-bit color palette.
  2) Easy transparency. Just store (Color transparent) at the desired position in the color map.
  3) Cheap color remapping by changing the color map.

A color map is an Array of up to 2^depth Color objects. A Bitmap colorMap is automatically computed and cached for rapid display. Note that if you change the color map, you must resubmit it via the colors: method to flush this cache.

ColorForms can be a bit tricky. Note that:
  a) When you BitBlt from one ColorForm to another, you must remember to copy the color map of the source ColorForm to the destination ColorForm.
  b) A ColorForm's color map is an array of depth-independent Color objects. BitBlt requires a BitMap of actual pixel values, adjusted to the destination depth. These are different things!! ColorForms automatically maintain a cache of the BitBlt-style color map corresponding to the colors array for the last depth on which the ColorForm was displayed, so there should be little need for clients to work with BitBlt-style color maps.
  c) The default map for 8 bit depth has black in the first entry, not transparent.  Say (cform colors at: 1 put: Color transparent).
!


!ColorForm methodsFor: 'accessing' stamp: 'jm 11/14/97 17:39'!
colors
    "Return my color palette."

    self ensureColorArrayExists.
    ^ colors
! !

!ColorForm methodsFor: 'accessing'!
colors: colorList
    "Set my color palette to the given collection."

    | colorArray colorCount newColors |
    colorList ifNil: [
        colors _ cachedDepth _ cachedColormap _ nil.
        ^ self].

    colorArray _ colorList asArray.
    colorCount _ colorArray size.
    newColors _ Array new: (1 bitShift: depth).
    1 to: newColors size do: [:i |
        i <= colorCount
            ifTrue: [newColors at: i put: (colorArray at: i)]
            ifFalse: [newColors at: i put: Color transparent]].

    colors _ newColors.
    cachedDepth _ nil.
    cachedColormap _ nil.
! !


!ColorForm methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm

    aDisplayMedium copyBits: self boundingBox
        from: self
        at: aDisplayPoint + self offset
        clippingBox: clipRectangle
        rule: rule
        fillColor: aForm
        map: (self colormapIfNeededForDepth: aDisplayMedium depth).
! !

!ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'!
displayOnPort: port at: location

    port copyForm: self to: location rule: Form paint! !


!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint
    "Return the color of the pixel at aPoint."

    ^ self colors at: (self pixelValueAt: aPoint) + 1
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/14/97 17:25'!
colorAt: aPoint put: aColor
    "Store the given color into the pixel at aPoint. The given color must match one of the colors in the receiver's colormap."

    | i |
    i _ self colors indexOf: aColor
        ifAbsent: [^ self error: 'trying to use a color that is not in my colormap'].
    self pixelValueAt: aPoint put: i - 1.
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'tk 10/21/97 12:27'!
isTransparentAt: aPoint
    "Return true if the receiver is transparent at the given point."

    ^ (self colorAt: aPoint) isTransparent
! !

!ColorForm methodsFor: 'pixel accessing' stamp: 'jm 11/16/97 10:43'!
pixelValueAt: aPoint
    "Return the raw pixel value at the given point. Typical clients use colorAt: to get a Color."
    "Details: To get the raw pixel value, be sure the peeker's colorMap is nil."

    ^ (BitBlt bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint
! !


!ColorForm methodsFor: 'color manipulation'!
colormapIfNeededForDepth: destDepth
    "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed."

    | newMap |
    colors == nil ifTrue: [
        "use the standard colormap"
        ^ Color colorMapIfNeededFrom: depth to: destDepth].

    destDepth = cachedDepth ifTrue: [^ cachedColormap].
    newMap _ Bitmap new: colors size.
    1 to: colors size do: [:i |
        newMap
            at: i
            put: ((colors at: i) pixelValueForDepth: destDepth)].

    cachedDepth _ destDepth.
    ^ cachedColormap _ newMap.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 4/18/98 20:34'!
colorsUsed
    "Return a list of the colors actually used by this ColorForm."

    | myColor list |
    myColor _ self colors.
    list _ OrderedCollection new.
    self tallyPixelValues doWithIndex: [:count :i |
        count > 0 ifTrue: [list add: (myColor at: i)]].
    ^ list asArray
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 11:18'!
ensureTransparentColor
    "Ensure that the receiver (a) includes Color transparent in its color map and (b) that the entry for Color transparent is the first entry in its color map."

    | i |
self error: 'not yet implemented'.
    (colors includes: Color transparent)
        ifTrue: [
            (colors indexOf: Color transparent) = 1 ifTrue: [^ self].
            "shift the entry for color transparent"]
        ifFalse: [
            i _ self unusedColormapEntry.
            i = 0 ifTrue: [self error: 'no color map entry is available'].
            colors at: i put: Color transparent.
            "shift the entry for color transparent"].
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 3/27/98 13:24'!
readFrom: aBinaryStream

    self error: 'not yet implemented'.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'jm 11/16/97 09:08'!
replaceColor: oldColor with: newColor
    "Replace all occurances of the given color with the given new color in my color map."

    self ensureColorArrayExists.
    1 to: colors size do: [:i |
        (colors at: i) = oldColor ifTrue: [colors at: i put: newColor]].
    self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 15:42'!
replaceColorAt: aPoint with: newColor
    "Replace a color map entry with newColor.  The entry replaced is the one used by aPoint.  If there are are two entries in the colorMap for the oldColor, just replace ONE!!!!  There are often two whites or two blacks, and this is what you want, when replacing one."

    | oldIndex |
    self ensureColorArrayExists.
    oldIndex _ self pixelValueAt: aPoint.
    colors at: oldIndex+1 put: newColor.
    self clearColormapCache.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:26'!
transparentAllPixelsLike: aPoint
    "Make all occurances of the given pixel value transparent.  Very useful when two entries in the colorMap have the same value.  This only changes ONE."

    self replaceColorAt: aPoint with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation' stamp: 'tk 3/2/98 11:27'!
transparentColor: aColor
    "Make all occurances of the given color transparent.  Note: for colors like black and white, which have two entries in the colorMap, this changes BOTH of them.  Not always what you want."

    self replaceColor: aColor with: Color transparent.
! !

!ColorForm methodsFor: 'color manipulation'!
twoToneFromDisplay: aRectangle backgroundColor: bgColor
    "Copy one-bit deep ColorForm from the Display using a color map that maps all colors except the background color to black. Used for caching the contents of inactive MVC windows."

    | map |
    (width = aRectangle width and: [height = aRectangle height])
        ifFalse: [self setExtent: aRectangle extent depth: depth].

    "make a color map mapping the background color
     to zero and all other colors to one"
    map _ Bitmap new: (1 bitShift: (Display depth min: 9)).
    1 to: map size do: [:i | map at: i put: 16rFFFFFFFF].
    map at: (bgColor indexInMap: map) put: 0.

    (BitBlt toForm: self)
        destOrigin: 0@0;
        sourceForm: Display;
        sourceRect: aRectangle;
        combinationRule: Form over;
        colorMap: map;
        copyBits.
! !


!ColorForm methodsFor: 'copying' stamp: 'tk 2/25/98 11:20'!
copy: aRect
     "Return a new ColorForm containing the portion of the receiver delineated by aRect."

    | newForm |
    newForm _ self class extent: aRect extent depth: depth.
    ((BitBlt
        destForm: newForm
        sourceForm: self
        fillColor: nil
        combinationRule: Form over
        destOrigin: 0@0
        sourceOrigin: aRect origin
        extent: aRect extent
        clipRect: newForm boundingBox)
        colorMap: nil) copyBits.
    colors ifNotNil: [newForm colors: colors copy].
    ^ newForm
! !

!ColorForm methodsFor: 'copying' stamp: 'jm 2/27/98 09:38'!
deepCopy

    ^ self shallowCopy
        bits: bits copy;
        offset: offset copy;
        colors: colors
! !


!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'!
clearColormapCache

    cachedDepth _ nil.
    cachedColormap _ nil.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:12'!
depth: bitsPerPixel

    bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
    super depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'!
ensureColorArrayExists
    "Return my color palette."

    colors ifNil: [
        depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits'].
        self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: depth))].
! !

!ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 08:37'!
setExtent: extent depth: bitsPerPixel
    "Create a virtual bit map with the given extent and bitsPerPixel."

    bitsPerPixel > 8 ifTrue: [self error: 'ColorForms only support depths up to 8 bits'].
    super setExtent: extent depth: bitsPerPixel.
! !

!ColorForm methodsFor: 'private' stamp: 'jm 2/24/98 18:53'!
unusedColormapEntry
    "Return the index of an unused color map entry, or zero if there isn't one."

    | tallies |
    tallies _ self tallyPixelValues.
    1 to: tallies size do: [:i |
        (tallies at: i) = 0 ifTrue: [^ i]].
    ^ 0
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ColorForm class
    instanceVariableNames: ''!

!ColorForm class methodsFor: 'all' stamp: 'jm 11/16/97 09:17'!
mappingWhiteToTransparentFrom: aFormOrCursor
    "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent."

    | f map |
    aFormOrCursor depth <= 8 ifFalse: [
        ^ self error: 'argument depth must be 8-bits per pixel or less'].
    (aFormOrCursor isKindOf: ColorForm) ifTrue: [
        f _ aFormOrCursor deepCopy.
        map _ aFormOrCursor colors.
    ] ifFalse: [
        f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth.
        f copyBits: aFormOrCursor boundingBox
            from: aFormOrCursor
            at: 0@0
            clippingBox: aFormOrCursor boundingBox
            rule: Form over
            fillColor: nil.
        map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)].
    map _ map collect: [:c |
        c = Color white ifTrue: [Color transparent] ifFalse: [c]].
    f colors: map.
    ^ f
! !

!ColorForm class methodsFor: 'all'!
twoToneFromDisplay: aRectangle using: oldForm backgroundColor: bgColor
    "Return a 1-bit deep ColorForm copied from the given rectangle of the display. All colors except the background color will be mapped to black."

    | f |
    ((oldForm ~~ nil) and: [oldForm extent = aRectangle extent]) ifTrue: [
        f _ oldForm fromDisplay: aRectangle.
    ] ifFalse: [
        f _ ColorForm extent: aRectangle extent depth: 1.
        f twoToneFromDisplay: aRectangle backgroundColor: bgColor.
        f colors: (Array
            with: bgColor
            with: Color black)].
    ^ f
! !
SketchMorph subclass: #ColorPickerMorph
    instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously selector target '
    classVariableNames: 'ColorChart FeedbackBox TransparentBox '
    poolDictionaries: ''
    category: 'Morphic-Widgets'!

!ColorPickerMorph methodsFor: 'initialization' stamp: 'jm 11/4/97 07:46'!
initialize

    super initialize.
    self form: ColorChart deepCopy.
    selectedColor _ Color white.
    sourceHand _ nil.
    deleteOnMouseUp _ true.
    updateContinuously _ true.
    selector _ nil.
    target _ nil.
! !


!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp

    ^ deleteOnMouseUp
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
deleteOnMouseUp: aBoolean

    deleteOnMouseUp _ aBoolean.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selectedColor

    ^ selectedColor
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selector

    ^ selector
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
selector: aSymbol

    selector _ aSymbol.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand

    ^ sourceHand
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
sourceHand: aHand

    sourceHand _ aHand.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
target

    ^ target
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:15'!
target: anObject

    target _ anObject.
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously

    ^ updateContinuously
! !

!ColorPickerMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'!
updateContinuously: aBoolean

    updateContinuously _ aBoolean.
! !


!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
handlesMouseDown: evt

    ^ true
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:15'!
mouseDown: evt

    sourceHand _ evt hand.
    self startStepping.
! !

!ColorPickerMorph methodsFor: 'event handling' stamp: 'jm 11/4/97 07:46'!
mouseUp: evt

    self stopStepping.
    sourceHand _ nil.
    deleteOnMouseUp ifTrue: [self delete].
    self updateTargetColor.
! !


!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'!
step

    sourceHand ifNotNil:
        [self pickColorAt: sourceHand position].
! !

!ColorPickerMorph methodsFor: 'stepping' stamp: 'jm 11/4/97 07:15'!
stepTime

    ^ 50
! !


!ColorPickerMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:15'!
pickColorAt: aPoint

    | worldBox globalP c |
    (FeedbackBox containsPoint: aPoint - self topLeft) ifTrue: [^ self].  "do nothing"

    "pick up color, either inside or outside this world"
    worldBox _ self world viewBox.
    globalP _ aPoint + worldBox topLeft.  "get point in screen coordinates"
    (worldBox containsPoint: globalP)
        ifTrue: [c _ self world colorAt: aPoint belowMorph: Morph new]
        ifFalse: [c _ Display colorAt: globalP].

    "check for transparent color and update using appropriate feedback color"
    (TransparentBox containsPoint: aPoint - self topLeft)
        ifTrue: [self updateColor: Color transparent feedbackColor: Color white]
        ifFalse: [self updateColor: c feedbackColor: c].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:46'!
updateColor: aColor feedbackColor: feedbackColor
    "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil."

    selectedColor = aColor ifTrue: [^ self].  "do nothing if color doesn't change"

    originalForm fill: FeedbackBox fillColor: feedbackColor.
    self form: originalForm.
    selectedColor _ aColor.
    updateContinuously ifTrue: [self updateTargetColor].
! !

!ColorPickerMorph methodsFor: 'private' stamp: 'jm 11/4/97 07:46'!
updateTargetColor

    ((target ~~ nil) and: [selector ~~ nil]) ifTrue: [
        selector numArgs = 2
            ifTrue: [target perform: selector with: selectedColor with: sourceHand]
            ifFalse: [target perform: selector with: selectedColor]].
! !


!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
addCustomMenuItems: aCustomMenu hand: aHandMorph

    super addCustomMenuItems: aCustomMenu hand: aHandMorph.
    deleteOnMouseUp
        ifTrue: [aCustomMenu add: 'stay up' action: #toggleDeleteOnMouseUp]
        ifFalse: [aCustomMenu add: 'do not stay up' action: #toggleDeleteOnMouseUp].
    updateContinuously
        ifTrue: [aCustomMenu add: 'update only at end' action: #toggleUpdateContinuously]
        ifFalse: [aCustomMenu add: 'update continuously' action: #toggleUpdateContinuously].
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleDeleteOnMouseUp

    deleteOnMouseUp _ deleteOnMouseUp not.
! !

!ColorPickerMorph methodsFor: 'menu' stamp: 'jm 11/4/97 07:46'!
toggleUpdateContinuously

    updateContinuously _ updateContinuously not.
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ColorPickerMorph class
    instanceVariableNames: ''!

!ColorPickerMorph class methodsFor: 'all' stamp: 'jm 5/13/1998 14:44'!
initialize
    "ColorPickerMorph initialize"

    ColorChart _ Color colorPaletteForDepth: 16 extent: 190@60.
    TransparentBox _ ColorChart boundingBox withHeight: 10.
    FeedbackBox _ (ColorChart width - 20)@0 extent: 20@9.
! !
ColorTileMorph subclass: #ColorSeerTile
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Tiles'!

!ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'sw 5/2/1998 15:00'!
initialize

    | m1 m2 desiredW |
    super initialize.
    self removeAllMorphs.    "get rid of the parts of a regular Color tile"
    type _ #operator.
    operatorOrExpression _ #color:sees:.
    m1 _ StringMorph new initWithContents: 'color    sees' font: ScriptingSystem fontForTiles.
    m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0).
    desiredW _ m1 width + 6.
    self extent: (desiredW max: self class defaultW) @ self class defaultH.
    m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 5).
    m2 position: (bounds center x - (m2 width // 2) + 3) @ (bounds top + 8).
    self addMorph: m1; addMorphFront: m2.
    colorSwatch _ m2.
    ! !

!ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'tk 12/2/97 13:12'!
storeCodeOn: aStream
    "We have a hidden arg.  Give 'keyword1: arg1 keyword2:' as my operator string"

    | parts |
    parts _ operatorOrExpression keywords.    "color:sees:"
    ^ aStream nextPutAll: (parts at: 1); space;
        nextPutAll: colorSwatch color printString; space;
        nextPutAll: (parts at: 2).

! !

!ColorSeerTile methodsFor: 'as yet unclassified' stamp: 'tk 12/3/97 09:51'!
updateLiteralLabel
    "Do nothing"! !
StandardSystemView subclass: #ColorSystemView
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Support'!

!ColorSystemView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
    ^ false! !

!ColorSystemView methodsFor: 'as yet unclassified' stamp: 'di 2/26/98 08:58'!
displayDeEmphasized
    "Display this view with emphasis off.
    If windowBits is not nil, then simply BLT if possible."
    bitsValid
        ifTrue: [self lock.
                windowBits displayAt: self windowOrigin]
        ifFalse: [super displayDeEmphasized]
! !
TileMorph subclass: #ColorTileMorph
    instanceVariableNames: 'colorSwatch '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Tiles'!

!ColorTileMorph methodsFor: 'initialization'!
initialize

    super initialize.
    type _ #literal.
    self addColorSwatch.
! !


!ColorTileMorph methodsFor: 'events'!
handlesMouseDown: evt

    (colorSwatch containsPoint: evt cursorPoint)
        ifTrue: [^ true]
        ifFalse: [^ super handlesMouseDown: evt].
! !

!ColorTileMorph methodsFor: 'events'!
mouseDown: evt

    (colorSwatch containsPoint: evt cursorPoint)
        ifFalse: [super mouseDown: evt].
! !

!ColorTileMorph methodsFor: 'events' stamp: 'jm 5/13/1998 14:47'!
mouseUp: evt

    evt hand changeColorTarget: colorSwatch selector: #color:.
    self acceptNewLiteral.
! !


!ColorTileMorph methodsFor: 'other' stamp: 'tk 9/17/97 18:13'!
addColorSwatch

    | m1 m2 desiredW |
    m1 _ StringMorph new contents: 'color'.
    m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0).
    desiredW _ m1 width + 6.
    self extent: (desiredW max: self class defaultW) @ self class defaultH.
    m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1).
    m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1).
    self addMorph: m1; addMorph: m2.
    colorSwatch _ m2.
! !

!ColorTileMorph methodsFor: 'other' stamp: 'jm 6/25/97 17:38'!
resultType

    ^ #color! !

!ColorTileMorph methodsFor: 'other'!
storeCodeOn: aStream

    aStream nextPutAll: colorSwatch color printString.
! !
AlignmentMorph subclass: #CommandTilesMorph
    instanceVariableNames: 'morph playerScripted '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Tiles'!
!CommandTilesMorph commentStamp: 'di 5/22/1998 16:32' prior: 0!
CommandTilesMorph comment:
'An entire Smalltalk statement in tiles.  A line of code.'!


!CommandTilesMorph methodsFor: 'all'!
initialize

    super initialize.
    centering _ #center.
    hResizing _ #shrinkWrap.
    borderWidth _ 0.
    inset _ 0.
    self extent: 5@5.  "will grow to fit"
! !

!CommandTilesMorph methodsFor: 'all' stamp: 'tk 10/1/97 18:25'!
isTileLike
    "Can be dropped into a script"
    ^ true! !

!CommandTilesMorph methodsFor: 'all' stamp: 'sw 1/29/98 18:32'!
setMorph: aMorph
    playerScripted _ aMorph playerScripted
! !

!CommandTilesMorph methodsFor: 'all'!
tileRows

    ^ Array with: self submorphs! !
Object subclass: #Comment
    instanceVariableNames: ''
    classVariableNames: 'CommentsTable '
    poolDictionaries: ''
    category: 'PluggableWebServer'!
!Comment commentStamp: 'di 5/22/1998 16:33' prior: 0!
A Comment space is like a bulletin board.  It is a web page with a list statements from many different people.  At the bottom there is a form for you to add your own statement.

Anyone may start a new comment page, just by asking for a page with a new key, and there can be any number of pages.  The default Swiki has a page called 'pws' already created.

The administrator must take special action to save the accumulated comments (Comment saveTo: 'aFileName').  Comments are not automatically stored on the disk like regular Swiki pages are.  So, for the moment, it is likely that Comments will get lost when the server is restarted.

URLs are of the form
machine:80/Comment.{commentKey}
machine:80/Comment.{commentKey}.{number}
machine:80/Comment.{commentKey}.note   -- Does this really work???  -tk
machine:80/Comment.{commentKey}.gif!


"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Comment class
    instanceVariableNames: ''!

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/10/97 10:44'!
initialize
    CommentsTable := Dictionary new.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'!
readIn: filename
    |f|
    f _ ReferenceStream fileNamed: filename.
    CommentsTable _ f next.
    f close.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/24/97 15:20'!
saveTo: filename
    |f|
    f _ ReferenceStream fileNamed: filename.
    f nextPut: CommentsTable.
    f close.! !

!Comment class methodsFor: 'initialization' stamp: 'mjg 11/17/97 14:52'!
setUpExample
    | newDiscussion |
    newDiscussion _ Discussion new.
    newDiscussion title: 'pws'.
    newDiscussion description: 'Here is a space for talking about the Pluggable Web Server.'.
    CommentsTable at: 'pws' put: newDiscussion.

! !


!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/10/97 11:18'!
comments
    ^CommentsTable! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 12/19/97 13:44'!
createComment: request
    "Create a new comment from a Web request"
    | newNote newMap |
    request fields isNil ifTrue: [self error: 'No request to create a comment from!!'].
    newNote := Note new.
    newMap := URLmap new.
    newNote author: (request fields at: 'author' ifAbsent: ['Anonymous']).
    newNote title: (request fields at: 'title' ifAbsent: ['Untitled']).
    newNote text: (HTMLformatter swikify:
        (request fields at: 'text' ifAbsent: ['Nothing much to say'])
        linkhandler: [:phrase | newMap linkFor: phrase from: (request peerName)
            storingTo: OrderedCollection new]).
    newNote timestamp: (Date today printString),' ',(Time now printString).
    newNote children: OrderedCollection new. "For later addition of threaded comments"
    ^newNote
! !

!Comment class methodsFor: 'URL processing' stamp: 'tk 5/6/1998 18:48'!
process: request
    "URLs are of the form Comment.commentKey or
    Comment.commentKey.note of Comment.commentKey.gif.

    If commentKey is accessed but not created, create an empty one.
    If note is accessed, display it."
    | commentKey noteIndex newNote |
    (request message size > 1) ifTrue: [commentKey _ request message at: 2]
    ifFalse: [commentKey _ 'comment' "Just a default comment space"].
    (CommentsTable includesKey: commentKey)
        ifFalse:
            [CommentsTable at: commentKey put: Discussion new.
            (CommentsTable at: commentKey)
                title: commentKey.
            (CommentsTable at: commentKey)
                description: 'Discussion on ' , commentKey].
    request fields isNil
        ifFalse:
            ["Are there input fields?"
            newNote _ self createComment: request.
            newNote parent: commentKey.
            (CommentsTable at: commentKey)
                addNote: newNote.
            newNote url: ('Comment.',commentKey,'.',
                (CommentsTable at: commentKey) notes size printString)].
    request message size > 2
        ifTrue:
            ["There's a note reference or a request for a status image"
            noteIndex _ request message at: 3.
            noteIndex asUppercase = 'GIF'
            ifTrue: [
            request reply: (PWS success),(PWS content: 'image/gif').
            request reply: (HTMLformatter textToGIF:
                (CommentsTable at: commentKey) status)]
            ifFalse: [request reply: (self showNote: ((CommentsTable at: commentKey)
                        at: noteIndex asNumber))]]
        ifFalse: [request reply: (self showComment: (CommentsTable at: commentKey))]! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'!
showComment: aComment
    | fileName |
    fileName := (ServerAction serverDirectory) , 'ShowComment.html'.
    ^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aComment.

! !

!Comment class methodsFor: 'URL processing' stamp: 'mjg 11/18/97 10:28'!
showNote: aNote
    | fileName |
    fileName := (ServerAction serverDirectory) , 'ShowNote.html'.
    ^HTMLformatter evalEmbedded: (FileStream fileNamed: fileName) contentsOfEntireFile with: aNote.
! !
ByteArray variableByteSubclass: #CompiledMethod
    instanceVariableNames: ''
    classVariableNames: 'LargeFrame SmallFrame SpecialConstants TempNameCache '
    poolDictionaries: ''
    category: 'Kernel-Methods'!
!CompiledMethod commentStamp: 'di 5/22/1998 16:33' prior: 0!
CompiledMethod comment:
'I represent a method suitable for interpretation by the virtual machine. My instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation).

An extra three bytes are added after the executable code. These contain an external file address to the source code for the method.'!


!CompiledMethod methodsFor: 'initialize-release'!
copyWithTrailerBytes: bytes
"Testing:
    (CompiledMethod compiledMethodAt: #copyWithTrailerBytes:)
        tempNamesPut: 'copy end '
"
    | copy end start |
    start _ self initialPC.
    end _ self endPC.
    copy _ CompiledMethod newMethod: end - start + 1 + bytes size
                header: self header.
    1 to: self numLiterals do: [:i | copy literalAt: i put: (self literalAt: i)].
    start to: end do: [:i | copy at: i put: (self at: i)].
    1 to: bytes size do: [:i | copy at: end + i put: (bytes at: i)].
    ^ copy! !

!CompiledMethod methodsFor: 'initialize-release'!
needsFrameSize: newFrameSize
    "Set the largeFrameBit to accomodate the newFrameSize.
    NOTE: I think the >= below is overly cautious.
    Recompile the system with just > some day - DI 2/26/96"
    | largeFrameBit header |
    largeFrameBit _ 16r20000.
    (self numTemps + newFrameSize) >= LargeFrame
        ifTrue: [^self error: 'Cannot compile--stack including temps is too deep'].
    header _ self objectAt: 1.
    (header bitAnd: largeFrameBit) ~= 0
        ifTrue: [header _ header - largeFrameBit].
    self objectAt: 1 put: header
            + ((self numTemps + newFrameSize) >= SmallFrame
                    ifTrue: [largeFrameBit]
                    ifFalse: [0])! !


!CompiledMethod methodsFor: 'accessing'!
bePrimitive: primitiveIndex
    "Used in conjunction with simulator only"
    self objectAt: 1
        put: ((self objectAt: 1) bitAnd: 16rFFFFFE00) + primitiveIndex! !

!CompiledMethod methodsFor: 'accessing'!
endPC
    "Answer the index of the last bytecode."
    | flagByte |
    flagByte _ self last.
    flagByte = 0 ifTrue:
        ["If last byte = 0, may be either 0, 0, 0, 0 or just 0"
        1 to: 4 do: [:i | (self at: self size - i) = 0 ifFalse: [^ self size - i]]].
    flagByte < 252 ifTrue:
        ["Magic sources (tempnames encoded in last few bytes)"
        ^ self size - self last - 1].
    "Normal 4-byte source pointer"
    ^ self size - 4! !

!CompiledMethod methodsFor: 'accessing'!
frameSize
    "Answer the size of temporary frame needed to run the receiver."

    (self header noMask: 16r20000)
        ifTrue: [^ SmallFrame]
        ifFalse: [^ LargeFrame]! !

!CompiledMethod methodsFor: 'accessing'!
initialPC
    "Answer the program counter for the receiver's first bytecode."

    ^ (self numLiterals + 1) * 4 + 1! !

!CompiledMethod methodsFor: 'accessing'!
numArgs
    "Answer the number of arguments the receiver takes."

    ^ (self header bitShift: -24) bitAnd: 16r1F! !

!CompiledMethod methodsFor: 'accessing'!
numLiterals
    "Answer the number of literals used by the receiver."

    ^ (self header bitShift: -9) bitAnd: 16rFF! !

!CompiledMethod methodsFor: 'accessing'!
numTemps
    "Answer the number of temporary variables used by the receiver."

    ^ (self header bitShift: -18) bitAnd: 16r3F! !

!CompiledMethod methodsFor: 'accessing' stamp: 'jm 9/18/97 21:06'!
primitive
    "Answer the primitive index associated with the receiver.
    Zero indicates that this is not a primitive method.
    We currently allow 11 bits of primitive index, but they are in two places
    for  backward compatibility.  The time to unpack is negligible,
    since the reconstituted full index is stored in the method cache."
    | primBits |
    primBits _ self header bitAnd: 16r300001FF.
    primBits > 16r1FF
        ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19)]
        ifFalse: [^ primBits]! !

!CompiledMethod methodsFor: 'accessing'!
returnField
    "Answer the index of the instance variable returned by a quick return
    method."
    | prim |
    prim _ self primitive.
    prim < 264
        ifTrue: [self error: 'only meaningful for quick-return']
        ifFalse: [^ prim - 264]! !

!CompiledMethod methodsFor: 'accessing' stamp: 'sw 8/15/97 16:17'!
selector
    "This is slow, so don't call it frivolously"
    ^ self who last! !


!CompiledMethod methodsFor: 'comparing'!
= method
    "Answer whether the receiver implements the same code as the
    argument, method."
    (method isKindOf: CompiledMethod) ifFalse: [^false].
    self size = method size ifFalse: [^false].
    self header = method header ifFalse: [^false].
    self literals = method literals ifFalse: [^false].
    self initialPC to: self endPC do:
        [:i | (self at: i) = (method at: i) ifFalse: [^false]].
    ^true! !


!CompiledMethod methodsFor: 'testing'!
isQuick
    "Answer whether the receiver is a quick return (of self or of an instance
    variable)."
    ^ self primitive >= 256! !

!CompiledMethod methodsFor: 'testing'!
isReturnField
    "Answer whether the receiver is a quick return of an instance variable."
    ^ self primitive >= 264! !

!CompiledMethod methodsFor: 'testing'!
isReturnSelf
    "Answer whether the receiver is a quick return of self."

    ^ self primitive = 256! !

!CompiledMethod methodsFor: 'testing'!
isReturnSpecial
    "Answer whether the receiver is a quick return of self or constant."

    ^ self primitive between: 256 and: 263! !


!CompiledMethod methodsFor: 'printing'!
decompileString
    | clAndSel cl sel |
    clAndSel _ self who.
    cl _ clAndSel first.
    sel _ clAndSel last.
    ^ (cl decompilerClass new
            decompile: sel in: cl method: self) decompileString! !

!CompiledMethod methodsFor: 'printing'!
printOn: aStream
    "Overrides method inherited from the byte arrayed collection."

    aStream nextPutAll: 'a CompiledMethod'! !

!CompiledMethod methodsFor: 'printing'!
storeLiteralsOn: aStream forClass: aBehavior
    "Store the literals referenced by the receiver on aStream, each terminated by a space."

    | literal |
    2 to: self numLiterals + 1 do:
        [:index |
         aBehavior storeLiteral: (self objectAt: index) on: aStream.
         aStream space]! !

!CompiledMethod methodsFor: 'printing'!
storeOn: aStream
    | noneYet |
    aStream nextPutAll: '(('.
    aStream nextPutAll: self class name.
    aStream nextPutAll: ' newMethod: '.
    aStream store: self size - self initialPC + 1.
    aStream nextPutAll: ' header: '.
    aStream store: self header.
    aStream nextPut: $).
    noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream.
    1 to: self numLiterals do:
        [:index |
        noneYet
            ifTrue: [noneYet _ false]
            ifFalse: [aStream nextPut: $;].
        aStream nextPutAll: ' literalAt: '.
        aStream store: index.
        aStream nextPutAll: ' put: '.
        aStream store: (self literalAt: index)].
    noneYet ifFalse: [aStream nextPutAll: '; yourself'].
    aStream nextPut: $)! !

!CompiledMethod methodsFor: 'printing'!
symbolic
    "Answer a String that contains a list of all the byte codes in a method
    with a short description of each."
    | aStream |
    self isQuick ifTrue:
        [self isReturnSpecial ifTrue: [^ 'Quick return ' ,
                (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2')
                        at: self primitive - 255)].
        ^ 'Quick return field ' , self returnField printString , ' (0-based)'].
    aStream _ WriteStream on: (String new: 1000).
    self primitive > 0
        ifTrue:
            [aStream nextPutAll: '<primitive: '.
            aStream print: self primitive.
            aStream nextPut: $>.
            aStream cr].
    (InstructionPrinter on: self) printInstructionsOn: aStream.
    ^aStream contents! !

!CompiledMethod methodsFor: 'printing' stamp: 'jm 9/3/97 11:05'!
who
    "Answer an Array of the class in which the receiver is defined and the
    selector to which it corresponds."

    Smalltalk allBehaviorsDo:
        [:class |
        class selectorsDo:
            [:sel |
            (class compiledMethodAt: sel) == self
                ifTrue: [^Array with: class with: sel]]].
    ^ Array with: #unknown with: #unknown
! !


!CompiledMethod methodsFor: 'literals' stamp: 'di 10/17/97 22:38'!
hasLiteral: literal
    "Answer whether the receiver references the argument, literal."

    <primitive: 132>  "a fast primitive operation equivalent to..."

    2 to: self numLiterals + 1 do:
        [:index |
        literal == (self objectAt: index) ifTrue: [^ true]].
    ^ false! !

!CompiledMethod methodsFor: 'literals' stamp: 'di 8/15/97 09:51'!
hasLiteralSuchThat: litBlock
    "Answer true if litBlock returns true for any literal in this method, even if imbedded in array structure."
    | lit |
    2 to: self numLiterals + 1 do:
        [:index | lit _ self objectAt: index.
        (litBlock value: lit) ifTrue: [^ true].
        (lit class == Array and: [lit hasLiteralSuchThat: litBlock]) ifTrue: [^ true]].
    ^false! !

!CompiledMethod methodsFor: 'literals'!
header
    "Answer the word containing the information about the form of the
    receiver and the form of the context needed to run the receiver."

    ^self objectAt: 1! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index
    "Answer the literal indexed by the argument."

    ^self objectAt: index + 1! !

!CompiledMethod methodsFor: 'literals'!
literalAt: index put: value
    "Replace the literal indexed by the first argument with the second
    argument. Answer the second argument."

    ^self objectAt: index + 1 put: value! !

!CompiledMethod methodsFor: 'literals'!
literals
    "Answer an Array of the literals referenced by the receiver."
    | literals numberLiterals |
    literals _ Array new: (numberLiterals _ self numLiterals).
    1 to: numberLiterals do:
        [:index |
        literals at: index put: (self objectAt: index + 1)].
    ^literals! !

!CompiledMethod methodsFor: 'literals'!
literalStrings
    | lits litStrs |
    lits _ self literals.
    litStrs _ OrderedCollection new: lits size * 3.
    self literals do:
        [:lit |
        (lit isMemberOf: Association)
            ifTrue: [litStrs addLast: lit key]
            ifFalse: [(lit isMemberOf: Symbol)
                ifTrue: [litStrs addAll: lit keywords]
                ifFalse: [litStrs addLast: lit printString]]].
    ^ litStrs! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index
    "Primitive. Answer the method header (if index=1) or a literal (if index
    >1) from the receiver. Essential. See Object documentation
    whatIsAPrimitive."

    <primitive: 68>
    self primitiveFailed! !

!CompiledMethod methodsFor: 'literals'!
objectAt: index put: value
    "Primitive. Store the value argument into a literal in the receiver. An
    index of 2 corresponds to the first literal. Fails if the index is less than 2
    or greater than the number of literals. Answer the value as the result.
    Normally only the compiler sends this message, because only the
    compiler stores values in CompiledMethods. Essential. See Object
    documentation whatIsAPrimitive."

    <primitive: 69>
    self primitiveFailed! !


!CompiledMethod methodsFor: 'scanning'!
messages
    "Answer a Set of all the message selectors sent by this method."

    | scanner aSet |
    aSet _ Set new.
    scanner _ InstructionStream on: self.
    scanner
        scanFor:
            [:x |
            scanner addSelectorTo: aSet.
            false    "keep scanning"].
    ^aSet! !

!CompiledMethod methodsFor: 'scanning'!
readsField: varIndex
    "Answer whether the receiver loads the instance variable indexed by the
    argument."

    self isReturnField ifTrue: [^self returnField + 1 = varIndex].
    varIndex <= 16 ifTrue: [^ self scanFor: varIndex - 1].
    varIndex <= 64 ifTrue: [^ self scanLongLoad: varIndex - 1].
    ^ self scanVeryLongLoad: 64 offset: varIndex - 1! !

!CompiledMethod methodsFor: 'scanning'!
readsRef: literalAssociation
    "Answer whether the receiver loads the argument."
    | lit |
    lit _ self literals indexOf: literalAssociation ifAbsent: [^false].
    lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].
    lit <= 64 ifTrue: [^self scanLongLoad: 192 + lit - 1].
    ^ self scanVeryLongLoad: 128 offset: lit - 1! !

!CompiledMethod methodsFor: 'scanning'!
scanFor: byte
    "Answer whether the receiver contains the argument as a bytecode."

    ^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"! !

!CompiledMethod methodsFor: 'scanning'!
scanLongLoad: extension
    "Answer whether the receiver contains a long load whose extension is the
    argument."

    | scanner |
    scanner _ InstructionStream on: self.
    ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanLongStore: extension
    "Answer whether the receiver contains a long store whose extension is
    the argument."
    | scanner |
    scanner _ InstructionStream on: self.
    ^scanner scanFor:
        [:instr |  (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! !

!CompiledMethod methodsFor: 'scanning'!
scanVeryLongLoad: extension offset: offset
    "Answer whether the receiver contains a long load whose extension is the
    argument."
    | scanner |
    scanner _ InstructionStream on: self.
    ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension])
                                            and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning' stamp: 'di 6/25/97 19:08'!
scanVeryLongStore: extension offset: offset
    "Answer whether the receiver contains a long load with the given offset.
    Note that the constant +32 is the known difference between a
    store and a storePop for instVars, and it will always fail on literal variables,
    but these only use store (followed by pop) anyway."
    | scanner ext |
    scanner _ InstructionStream on: self.
    ^ scanner scanFor:
        [:instr | (instr = 132 and: [(ext _ scanner followingByte) = extension
                                            or: ["might be a store/pop into rcvr"
                                                ext = (extension+32)]])
                            and: [scanner thirdByte = offset]]! !

!CompiledMethod methodsFor: 'scanning'!
sendsToSuper
    "Answer whether the receiver sends any message to super."
    | scanner |
    scanner _ InstructionStream on: self.
    ^ scanner scanFor:
        [:instr |  instr = 16r85 or: [instr = 16r84
                        and: [scanner followingByte between: 16r20 and: 16r3F]]]! !

!CompiledMethod methodsFor: 'scanning'!
writesField: field
    "Answer whether the receiver stores into the instance variable indexed
    by the argument."

    self isQuick ifTrue: [^false].
    field <= 8 ifTrue: [^ (self scanFor: 96 + field - 1)
                        or: [self scanLongStore: field - 1]].
    field <= 64 ifTrue: [^ self scanLongStore: field - 1].
    ^ self scanVeryLongStore: 160 offset: field - 1! !

!CompiledMethod methodsFor: 'scanning'!
writesRef: ref
    "Answer whether the receiver stores the argument."
    | lit |
    lit _ self literals indexOf: ref ifAbsent: [^false].
    lit <= 64 ifTrue: [^ self scanLongStore: 192 + lit - 1].
    ^ self scanVeryLongStore: 224 offset: lit - 1! !


!CompiledMethod methodsFor: 'source code management'!
cacheTempNames: names

    TempNameCache _ Association key: self value: names! !

!CompiledMethod methodsFor: 'source code management'!
copyWithTempNames: tempNames
    | tempStr |
    tempStr _ String streamContents:
        [:strm | tempNames do: [:n | strm nextPutAll: n; space]].
    ^ self copyWithTrailerBytes: (self qCompress: tempStr)! !

!CompiledMethod methodsFor: 'source code management'!
fileIndex
    "Answer the index of the sources file on which this method is stored, as follows:
        1:    .sources file
        2:    .changes file
        3 and 4 are also available for future extension of source code management"

    self last < 252 ifTrue: [^ 0  "no source"].
    ^ self last - 251

    ! !

!CompiledMethod methodsFor: 'source code management'!
filePosition
    "Answer the file position of this method's source code."
    | pos |
    self last < 252 ifTrue: [^ 0  "no source"].
    pos _ 0.
    self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)].
    ^ pos! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 8/15/97 14:27'!
getSourceFor: selector in: class
    "Retrieve or reconstruct the source code for this method."
    | source flagByte |
    flagByte _ self last.
    flagByte = 0 ifTrue:
        ["No source pointer -- decompile without temp names"
        ^ (class decompilerClass new decompile: selector in: class method: self)
            decompileString].
    flagByte < 252 ifTrue:
        ["Magic sources -- decompile with temp names"
        ^ ((class decompilerClass new withTempNames: self tempNames)
                decompile: selector in: class method: self)
            decompileString].

    "Situation normal;  read the sourceCode from the file"
    (source _ self getSourceFromFile) == nil ifFalse: [^ source].

    "Something really wrong -- decompile blind (no temps)"
    ^ (class decompilerClass new decompile: selector in: class method: self)
            decompileString! !

!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/12/97 13:03'!
getSourceFromFile
    "Read the source code from file, determining source file index and
    file position from the last 3 bytes of this method."
    | position |
    (position _ self filePosition) = 0 ifTrue: [^ nil].
    ^ (RemoteString newFileNumber: self fileIndex position: position)
            text! !

!CompiledMethod methodsFor: 'source code management'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
    inFile: fileIndex priorMethod: priorMethod

    ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
            [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod.
            file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'!
putSource: sourceStr fromParseNode: methodNode class: class category: catName
    withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod

    ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble:
            [:file |
            class printCategoryChunk: catName on: file
                withStamp: changeStamp priorMethod: priorMethod.
            file cr]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'tk 12/11/97 16:21'!
putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock
    "Store the source code for the receiver on an external file.
    If no sources are available, i.e., SourceFile is nil, then store
    temp names for decompilation at the end of the method.
    If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes,
    in each case, storing a 4-byte source code pointer at the method end."
    | file remoteString |
    (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue:
        [^ self become: (self copyWithTempNames: methodNode tempNames)].
    file setToEnd.
    preambleBlock value: file.  "Write the preamble"
    remoteString _ RemoteString newString: sourceStr
                        onFileNumber: fileIndex toFile: file.
    file nextChunkPut: ' '; flush.
    self setSourcePosition: remoteString position inFile: fileIndex! !

!CompiledMethod methodsFor: 'source code management'!
qCompress: str
    "A very simple text compression routine designed for method temp names.
    Most common 12 chars get values 0-11 packed in one 4-bit nibble;
    others get values 12-15 (2 bits) * 16 plus next nibble.
    Last char of str must be a space so it may be dropped without
    consequence if output ends on odd nibble."
    | charTable odd ix oddNibble |
    charTable _  "Character encoding table must match qDecompress:"
    ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
    ^ ByteArray streamContents:
        [:strm | odd _ true.  "Flag for odd or even nibble out"
        str do:
            [:char | ix _ (charTable indexOf: char) - 1.
            (ix <= 12 ifTrue: [ix]
                ifFalse: [Array with: ix//16+12 with: ix\\16])
                do:
                [:nibble | (odd _ odd not)
                    ifTrue: [strm nextPut: oddNibble*16 + nibble]
                    ifFalse: [oddNibble _ nibble]]].
        strm nextPut: strm position]
"
  | m s |  m _ CompiledMethod new.
s _ 'charTable odd ix oddNibble '.
^ Array with: s size with: (m qCompress: s) size
    with: (m qDecompress: (m qCompress: s))
"
! !

!CompiledMethod methodsFor: 'source code management'!
qDecompress: byteArray
    "Decompress strings compressed by qCompress:.
    Most common 12 chars get values 0-11 packed in one 4-bit nibble;
    others get values 12-15 (2 bits) * 16 plus next nibble"
    |  charTable extended ext |
    charTable _  "Character encoding table must match qCompress:"
    ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'.
    ^ String streamContents:
        [:strm | extended _ false.  "Flag for 2-nibble characters"
        byteArray do:
            [:byte |
            (Array with: byte//16 with: byte\\16)
                do:
                [:nibble | extended
                    ifTrue: [strm nextPut: (charTable at: ext*16+nibble + 1). extended _ false]
                    ifFalse: [nibble < 12 ifTrue: [strm nextPut: (charTable at: nibble + 1)]
                                    ifFalse: [ext _ nibble-12.  extended _ true]]]]]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 6/15/97 09:14'!
setSourcePointer: srcPointer
    self setSourcePosition: srcPointer \\ 16r1000000 inFile: srcPointer // 16r1000000! !

!CompiledMethod methodsFor: 'source code management'!
setSourcePosition: position inFile: fileIndex
    "Store the location of the source code for the receiver in the receiver. The
    location consists of which source file (*.sources or *.changes) and the
    position in that file."

    fileIndex > 4 ifTrue: [^ self error: 'invalid file number'].
    self at: self size put: 251 + fileIndex.
    1 to: 3 do:
        [:i | self at: self size - i put: ((position bitShift: (i-3)*8) bitAnd: 16rFF)].
! !

!CompiledMethod methodsFor: 'source code management'!
setTempNamesIfCached: aBlock
    "This is a cache used by the debugger, independent of the storage of
    temp names when the system is converted to decompilation with temps."
    TempNameCache == nil ifTrue: [^self].
    TempNameCache key == self
        ifTrue: [aBlock value: TempNameCache value]! !

!CompiledMethod methodsFor: 'source code management' stamp: 'di 6/15/97 09:13'!
sourcePointer
    ^ (self fileIndex * 16r1000000) + self filePosition! !

!CompiledMethod methodsFor: 'source code management'!
tempNames
    | byteCount bytes |
    byteCount _ self at: self size.
    byteCount = 0 ifTrue: [^ Array new].
    bytes _ (ByteArray new: byteCount)
        replaceFrom: 1 to: byteCount with: self
        startingAt: self size - byteCount.
    ^ (self qDecompress: bytes) findTokens: ' '! !


!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/24/98 12:58'!
readDataFrom: aDataStream size: varsOnDisk
    "Make self be an object based on the contents of aDataStream, which was generated by the object's storeDataOn: method. Return self.  Must read both objects for the literals and bytes for the bytecodes."

    | lits |
    aDataStream beginReference: self.
    self objectAt: 1 put: aDataStream next.    "the header"
    lits _ self numLiterals + 1.    "counting header"
    2 to: lits do:
        [:ii | self objectAt: ii put: aDataStream next].
    lits*4+1 to: self basicSize do:
        [:ii | self basicAt: ii put: aDataStream byteStream next].
            "Get raw bytes directly from the file"
    ^ self! !

!CompiledMethod methodsFor: 'file in/out' stamp: 'tk 3/26/98 09:10'!
storeDataOn: aDataStream
    "Store myself on a DataStream.  I am a mixture of objects and raw data bytes.  Only use this for blocks.  Normal methodDictionaries should not be put out using ReferenceStreams.  Their fileOut should be attached to the beginning of the file."

    | byteLength lits |
    "No inst vars of the normal type"
    byteLength _ self basicSize.
    aDataStream
        beginInstance: self class
        size: byteLength.
    lits _ self numLiterals + 1.    "counting header"
    1 to: lits do:
        [:ii | aDataStream nextPut: (self objectAt: ii)].
    lits*4+1 to: byteLength do:
        [:ii | aDataStream byteStream nextPut: (self basicAt: ii)].
            "write bytes straight through to the file"! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CompiledMethod class
    instanceVariableNames: ''!

!CompiledMethod class methodsFor: 'class initialization'!
initialize    "CompiledMethod initialize"
    "Initialize class variables specifying the size of the temporary frame
    needed to run instances of me."

    SmallFrame _ 12.    "Context range for temps+stack"
    LargeFrame _ 32.! !


!CompiledMethod class methodsFor: 'instance creation'!
new
    "This will not make a meaningful method, but it could be used
    to invoke some otherwise useful method in this class."
    ^ self newMethod: 0 header: 0! !

!CompiledMethod class methodsFor: 'instance creation' stamp: 'jm 9/18/97 21:06'!
newBytes: numberOfBytes nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
    "Answer an instance of me. The header is specified by the message
    arguments. The remaining parts are not as yet determined."
    | largeBit primBits |
    largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
    primBits _ primitiveIndex <= 16r1FF
        ifTrue: [primitiveIndex]
        ifFalse: ["For now the high 2 bits of primitive no. are in high bits of header"
                (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r600) bitShift: 19)].
    ^ self newMethod: numberOfBytes + 4     " +4 to store source code ptr"
        header: (nArgs bitShift: 24) +
                (nTemps bitShift: 18) +
                (largeBit bitShift: 17) +
                (nLits bitShift: 9) +
                primBits! !

!CompiledMethod class methodsFor: 'instance creation'!
newMethod: numberOfBytes header: headerWord
    "Primitive. Answer an instance of me. The number of literals (and other
    information) is specified the headerWord. The first argument specifies
    the number of fields for bytecodes in the method. Fail if either
    argument is not a SmallInteger, or if numberOfBytes is negative. Once
    the header of a method is set by this primitive, it cannot be changed in
    any way. Essential. See Object documentation whatIsAPrimitive."

    <primitive: 79>
    (numberOfBytes isInteger and:
     [headerWord isInteger and:
     [numberOfBytes >= 0]]) ifTrue: [
        "args okay; space must be low"
        Smalltalk signalLowSpace.
        "retry if user proceeds"
        ^ self newMethod: numberOfBytes header: headerWord
    ].
    ^self primitiveFailed! !

!CompiledMethod class methodsFor: 'instance creation'!
toReturnConst: constCode
    "Answer an instance of me that is a quick return of a constant
    constCode = 1...7  ->  true, false, nil, -1, 0, 1, 2."

    ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + constCode! !

!CompiledMethod class methodsFor: 'instance creation'!
toReturnConstant: index
    "Answer an instance of me that is a quick return of the constant
    indexed in (true false nil -1 0 1 2)."

    ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + index
! !

!CompiledMethod class methodsFor: 'instance creation'!
toReturnField: field
    "Answer an instance of me that is a quick return of the instance variable
    indexed by the argument, field."

    ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 264 + field
! !

!CompiledMethod class methodsFor: 'instance creation'!
toReturnSelf
    "Answer an instance of me that is a quick return of the instance (^self)."

    ^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256
! !
Object subclass: #Compiler
    instanceVariableNames: 'sourceStream requestor class context '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Compiler'!
!Compiler commentStamp: 'di 5/22/1998 16:33' prior: 0!
Compiler comment:
'The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.'!


!Compiler methodsFor: 'error handling'!
interactive
    "Answer whether there is a requestor of the compiler who should be
    informed that an error occurred."

    ^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not! !

!Compiler methodsFor: 'error handling'!
notify: aString
    "Refer to the comment in Object|notify:."

    ^self notify: aString at: sourceStream position + 1! !

!Compiler methodsFor: 'error handling'!
notify: aString at: location
    "Refer to the comment in Object|notify:."

    requestor == nil
        ifTrue: [^SyntaxError
                    errorInClass: class
                    withCode:
                        (sourceStream contents
                            copyReplaceFrom: location
                            to: location - 1
                            with: aString)]
        ifFalse: [^requestor
                    notify: aString
                    at: location
                    in: sourceStream]! !


!Compiler methodsFor: 'public access'!
compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock
    "Answer a MethodNode for the argument, textOrStream. If the
    MethodNode can not be created, notify the argument, aRequestor; if
    aRequestor is nil, evaluate failBlock instead. The MethodNode is the root
    of a parse tree. It can be told to generate a CompiledMethod to be
    installed in the method dictionary of the argument, aClass."

    self from: textOrStream
        class: aClass
        context: nil
        notifying: aRequestor.
    ^self
        translate: sourceStream
        noPattern: false
        ifFail: failBlock! !

!Compiler methodsFor: 'public access'!
evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock
    "Compiles the sourceStream into a parse tree, then generates code into a
    method. This method is then installed in the receiver's class so that it
    can be invoked. In other words, if receiver is not nil, then the text can
    refer to instance variables of that receiver (the Inspector uses this). If
    aContext is not nil, the text can refer to temporaries in that context (the
    Debugger uses this). If aRequestor is not nil, then it will receive a
    notify:at: message before the attempt to evaluate is aborted. Finally, the
    compiled method is invoked from here as DoIt or (in the case of
    evaluation in aContext) DoItIn:. The method is subsequently removed
    from the class, but this will not get done if the invocation causes an
    error which is terminated. Such garbage can be removed by executing:
    Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector:
    #DoItIn:]."

    | methodNode method value |
    class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class.
    self from: textOrStream class: class context: aContext notifying: aRequestor.
    methodNode _ self translate: sourceStream noPattern: true ifFail:
        [^failBlock value].
    method _ methodNode generate: #(0 0 0 0).
    context == nil
        ifTrue: [class addSelector: #DoIt withMethod: method.
                value _ receiver DoIt.
                class removeSelectorSimply: #DoIt.
                ^value]
        ifFalse: [class addSelector: #DoItIn: withMethod: method.
                value _ receiver DoItIn: context.
                class removeSelectorSimply: #DoItIn:.
                ^value]! !

!Compiler methodsFor: 'public access'!
format: textOrStream in: aClass notifying: aRequestor
    "Compile a parse tree from the argument, textOrStream. Answer a string
    containing the original code, formatted nicely.
    If the leftShift key is pressed, then decorate the resulting text with
    color and hypertext actions"
    | aNode |
    self from: textOrStream
        class: aClass
        context: nil
        notifying: aRequestor.
    aNode _ self format: sourceStream noPattern: false ifFail: [^nil].
    Sensor leftShiftDown
        ifTrue: [^ aNode decompileText]
        ifFalse: [^ aNode decompileString]! !

!Compiler methodsFor: 'public access'!
parse: textOrStream in: aClass notifying: req
    "Compile the argument, textOrStream, with respect to the class, aClass,
    and answer the MethodNode that is the root of the resulting parse tree.
    Notify the argument, req, if an error occurs. The failBlock is defaulted to
    an empty block."

    self from: textOrStream class: aClass context: nil notifying: req.
    ^self translate: sourceStream noPattern: false ifFail: []! !


!Compiler methodsFor: 'private'!
format: aStream noPattern: noPattern ifFail: failBlock

    | tree |
    tree _
        Parser new
            parse: aStream
            class: class
            noPattern: noPattern
            context: context
            notifying: requestor
            ifFail: [^failBlock value].
    ^tree! !

!Compiler methodsFor: 'private'!
from: textOrStream class: aClass context: aContext notifying: req

    (textOrStream isKindOf: PositionableStream)
        ifTrue: [sourceStream _ textOrStream]
        ifFalse: [sourceStream _ ReadStream on: textOrStream asString].
    class _ aClass.
    context _ aContext.
    requestor _ req! !

!Compiler methodsFor: 'private'!
translate: aStream noPattern: noPattern ifFail: failBlock

    | tree |
    tree _
        Parser new
            parse: aStream
            class: class
            noPattern: noPattern
            context: context
            notifying: requestor
            ifFail: [^failBlock value].
    ^tree! !

!Compiler methodsFor: 'private'!
translate: aStream withLocals: localDict noPattern: noPattern ifFail: failBlock

    | tree |
    tree _
        Parser new
            parse: aStream
            class: class
            noPattern: noPattern
            locals: localDict
            notifying: requestor
            ifFail: [^failBlock value].
    ^tree! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Compiler class
    instanceVariableNames: ''!

!Compiler class methodsFor: 'accessing'!
parserClass
    "Return a parser class to use for parsing method headers."

    ^Parser! !


!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString
    "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
    a Syntax Error view is created rather than notifying any requestor.
    Compilation is carried out with respect to nil, i.e., no object, and the
    invocation is not logged."

    ^self evaluate: textOrString for: nil logged: false! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString for: anObject logged: logFlag
    "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
    a Syntax Error view is created rather than notifying any requestor."

    ^self evaluate: textOrString for: anObject notifying: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString for: anObject notifying: aController logged: logFlag
    "Compile and execute the argument, textOrString with respect to the class
    of anObject. If a compilation error occurs, notify aController. If both
    compilation and execution are successful then, if logFlag is true, log
    (write) the text onto a system changes file so that it can be replayed if
    necessary."

    | val |
    val _ self new
                evaluate: textOrString
                in: nil
                to: anObject
                notifying: aController
                ifFail: [^nil].
    logFlag ifTrue: [Smalltalk logChange: textOrString].
    ^val! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString logged: logFlag
    "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs,
    a Syntax Error view is created rather than notifying any requestor.
    Compilation is carried out with respect to nil, i.e., no object."

    ^self evaluate: textOrString for: nil logged: logFlag! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString notifying: aController logged: logFlag
    "See Compiler|evaluate:for:notifying:logged:. Compilation is carried out
    with respect to nil, i.e., no object."

    ^self evaluate: textOrString for: nil notifying: aController logged: logFlag! !
Player subclass: #Component
    instanceVariableNames: 'model pinSpecs '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Components'!

!Component methodsFor: 'initialize' stamp: 'di 5/3/1998 20:23'!
initComponentIn: aLayout
    model _ aLayout model.
    self nameMeIn: aLayout world.
    self color: Color lightCyan.
    self showPins.
    model addDependent: self! !


!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:48'!
chooseNameLike: someName
    | stem otherNames i partName |
    stem _ someName.
    (stem size > 5 and: [stem endsWith: 'Morph'])
        ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
    stem _ stem first asLowercase asString , stem allButFirst.
    otherNames _ self class allInstVarNames asSet.
    "otherNames addAll: self world allKnownNames."
    i _ 1.
    [otherNames includes: (partName _ stem , i printString)]
        whileTrue: [i _ i + 1].
    partName _ FillInTheBlank request: 'Please give this part a name'
                        initialAnswer: partName.
    partName isEmpty ifTrue: [^ nil].
    (otherNames includes: partName) ifTrue:
            [self inform: 'Sorry, that name is already used'.
            ^ nil].
    ^ partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:58'!
externalName
    ^ self class name! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:50'!
nameMeIn: aWorld
    | stem otherNames i partName className |
    className _ self class name.
    stem _ className.
    (stem size > 5 and: [stem endsWith: 'Morph'])
        ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
    stem _ stem first asLowercase asString , stem allButFirst.
    otherNames _ Set newFrom: aWorld allKnownNames.
    i _ 1.
    [otherNames includes: (partName _ stem , i printString)]
        whileTrue: [i _ i + 1].
    self setNamePropertyTo: partName! !

!Component methodsFor: 'naming' stamp: 'di 5/3/1998 19:51'!
renameMe
    | newName |
    newName _ self chooseNameLike: self knownName.
    newName ifNil: [^ nil].
    self setNamePropertyTo: newName! !


!Component methodsFor: 'drag and drop' stamp: 'di 5/3/1998 20:08'!
justDroppedInto: aMorph event: anEvent
    | theModel |
    theModel _ aMorph model.
    ((aMorph isKindOf: ComponentLayout)
        and: [theModel isKindOf: Component]) ifFalse:
        ["Disconnect prior to removal by move"
        (theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
        ^ self].
    theModel == model ifTrue: [^ self  "Presumably just a move"].
    self initComponentIn: aMorph! !


!Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:46'!
addVariableNamed: varName
    | otherNames i partName |
    "Adjust name if necessary and add it"
    otherNames _ self class allInstVarNames.
    i _ nil.
    [i == nil ifTrue: [partName _ varName] ifFalse: [partName _ varName, i printString].
    otherNames includes: partName]
        whileTrue: [i == nil ifTrue: [i _ 1] ifFalse: [i _ i + 1]].
    self class addInstVarName: partName.

    "Now compile read method and write-with-change method"
    self class compile: (String streamContents:
            [:s | s nextPutAll: partName; cr;
            tab; nextPutAll: '^', partName])
        classified: 'view access'
        notifying: nil.
    self class compile: (String streamContents:
            [:s | s nextPutAll: partName, 'Set: newValue'; cr;
                tab; nextPutAll: partName, ' _ newValue.'; cr;
                tab; nextPutAll: 'self changed: #', partName])
        classified: 'view access'
        notifying: nil.

    ^ Array with: partName asSymbol with: (partName , 'Set:') asSymbol! !

!Component methodsFor: 'variables' stamp: 'di 5/3/1998 19:58'!
removeVariableNamed: varName
    self class removeSelector: varName.
    self class removeSelector: (varName , 'Set:') asSymbol.
    self class removeInstVarName: varName asString! !


!Component methodsFor: 'misc' stamp: 'di 5/3/1998 20:01'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

    super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
    aMenu add: 'delete' action: #dismissMorph! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Component class
    instanceVariableNames: ''!

!Component class methodsFor: 'all' stamp: 'di 4/17/1998 14:02'!
acceptsLoggingOfCompilation
    "Log everything for now"

    ^ true! !

!Component class methodsFor: 'all' stamp: 'di 4/18/1998 11:08'!
addSlotNamed: aName
    (self allInstVarNames includes: aName) ifTrue: [self error: 'Duplicate slot name'].
    self addInstVarName: aName.
! !

!Component class methodsFor: 'all' stamp: 'di 5/2/1998 10:40'!
compileAccessorsFor: varName
    "This should come around and invoke the new implementation
    inherited from Player (instance)"
    ^ self basicNew compileAccessorsFor: varName
! !

!Component class methodsFor: 'all' stamp: 'di 4/13/98 12:15'!
includeInNewMorphMenu
    "Only include instances of subclasses of me"
    ^ self ~~ Component! !

!Component class methodsFor: 'all' stamp: 'di 5/3/1998 19:55'!
wantsChangeSetLogging
    "Log changes for Component itself, but not for automatically-created subclasses like Component1, Component2"

    "^ self == Component or:
        [(self class name beginsWith: 'Component') not]"

    "Log everything for now"
    false ifTrue: [self halt  "DONT FORGET TO REORDER FILEOUT"].
    ^ true! !
Component subclass: #Component1
    instanceVariableNames: 'printComponent1value listComponent1selectedItem functionComponent1output listComponent2selectedItem functionComponent2output functionComponent3output listComponent3selectedItem functionComponent4output listComponent4selectedItem functionComponent5output '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Components-Demo'!

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'!
functionComponent1output
    ^functionComponent1output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:31'!
functionComponent1outputSet: newValue
    functionComponent1output _ newValue.
    self changed: #functionComponent1output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent2output
    ^functionComponent2output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent2outputSet: newValue
    functionComponent2output _ newValue.
    self changed: #functionComponent2output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent3output
    ^functionComponent3output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:35'!
functionComponent3outputSet: newValue
    functionComponent3output _ newValue.
    self changed: #functionComponent3output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'!
functionComponent4output
    ^functionComponent4output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:42'!
functionComponent4outputSet: newValue
    functionComponent4output _ newValue.
    self changed: #functionComponent4output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'!
functionComponent5output
    ^functionComponent5output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:49'!
functionComponent5outputSet: newValue
    functionComponent5output _ newValue.
    self changed: #functionComponent5output! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'!
listComponent1selectedItem
    ^listComponent1selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:30'!
listComponent1selectedItemSet: newValue
    listComponent1selectedItem _ newValue.
    self changed: #listComponent1selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:32'!
listComponent2selectedItem
    ^listComponent2selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:32'!
listComponent2selectedItemSet: newValue
    listComponent2selectedItem _ newValue.
    self changed: #listComponent2selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'!
listComponent3selectedItem
    ^listComponent3selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:41'!
listComponent3selectedItemSet: newValue
    listComponent3selectedItem _ newValue.
    self changed: #listComponent3selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'!
listComponent4selectedItem
    ^listComponent4selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:48'!
listComponent4selectedItemSet: newValue
    listComponent4selectedItem _ newValue.
    self changed: #listComponent4selectedItem! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'!
printComponent1value
    ^printComponent1value! !

!Component1 methodsFor: 'view access' stamp: 'di 5/8/1998 23:29'!
printComponent1valueSet: newValue
    printComponent1value _ newValue.
    self changed: #printComponent1value! !


!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:31'!
functionComponent1a: a
    ^ SystemOrganization listAtCategoryNamed: a! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:36'!
functionComponent2a: a
    ^ Smalltalk at: a! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:36'!
functionComponent3a: a
    ^ a organization categories! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:43'!
functionComponent4a: a b: b
    ^ a organization listAtCategoryNamed: b! !

!Component1 methodsFor: 'functions' stamp: 'di 5/8/1998 23:51'!
functionComponent5a: a b: b
    ^ a sourceCodeAt: b! !
PasteUpMorph subclass: #ComponentLayout
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Components'!

!ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 10:17'!
acceptDroppingMorph: aMorph event: evt
    "Eschew all of PasteUp's mechanism for now"

    self addMorph: aMorph.
! !

!ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 09:44'!
addCustomMenuItems: menu hand: aHandMorph

    super addCustomMenuItems: menu hand: aHandMorph.
    menu addLine.
    menu add: 'inspect model in morphic' action: #inspectModelInMorphic! !

!ComponentLayout methodsFor: 'all' stamp: 'di 5/5/1998 01:02'!
allKnownNames
    ^ (self submorphs collect: [:m | m knownName] thenSelect: [:m | m ~~ nil])! !

!ComponentLayout methodsFor: 'all' stamp: 'di 5/2/1998 21:36'!
createCustomModel
    "Create a model object for this world if it does not yet have one.
    The default model for an EditView is a Component."

    model == nil ifFalse: [^ self].  "already has a model"
    model _ Component newSubclass new.
! !

!ComponentLayout methodsFor: 'all' stamp: 'di 5/4/1998 08:01'!
initialize
    super initialize.
    self extent: 384@256! !

!ComponentLayout methodsFor: 'all' stamp: 'di 5/3/1998 09:41'!
inspectModelInMorphic
    | insp |
    insp _ InspectorBrowser openAsMorphOn: self model.
    self world addMorph: insp; startStepping: insp! !
MorphicModel subclass: #ComponentLikeModel
    instanceVariableNames: 'pinSpecs '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Components'!

!ComponentLikeModel methodsFor: 'initialization' stamp: 'di 5/3/1998 09:24'!
duplicate: newGuy from: oldGuy
    "oldGuy has just been duplicated and will stay in this world.  Make sure all the ComponentLikeModel requirements are carried out for the copy.  Ask user to rename it.  "

    newGuy installModelIn: oldGuy pasteUpMorph.
    newGuy copySlotMethodsFrom: oldGuy slotName.! !


!ComponentLikeModel methodsFor: 'compilation' stamp: 'di 5/3/1998 09:25'!
choosePartName
    "When I am renamed, get a slot, make default methods, move any existing methods."
    | old |
    (self pasteUpMorph model isKindOf: Component) ifTrue:
        [self knownName ifNil: [^ self nameMeIn: self pasteUpMorph]
                    ifNotNil: [^ self renameMe]].
    old _ slotName.
    super choosePartName.
    slotName ifNil: [^ self].  "user chose bad slot name"
    self model: self world model slotName: slotName.
    old == nil
        ifTrue: [self compilePropagationMethods]
        ifFalse: [self copySlotMethodsFrom: old].
            "old ones not erased!!"! !


!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 22:10'!
addAddHandMenuItemsForHalo: aMenu hand: aHandMorph

    super addAddHandMenuItemsForHalo: aMenu hand: aHandMorph.
    aMenu addLine.
    aMenu add: 'inspect' action: #inspectMorph.
    aMenu add: 'delete' action: #dismissMorph! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:14'!
addPinFromSpec: pinSpec
    | pin |
    pin _ PinMorph new component: self pinSpec: pinSpec.
    self addMorph: pin.
    pin placeFromSpec.
    ^ pin! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/16/1998 16:36'!
delete

    (model isKindOf: Component) ifTrue: [^ self deleteComponent].
    (model isKindOf: MorphicModel) ifFalse: [^ super delete].

    (PopUpMenu confirm:
'Shall I remove the slot ', slotName, '
along with all associated methods?') ifTrue: [
        (model class selectors select: [:s | s beginsWith: slotName])
            do: [:s | model class removeSelector: s].
        (model class instVarNames includes: slotName)
            ifTrue: [model class removeInstVarName: slotName].
    ] ifFalse: [
        (PopUpMenu confirm:
'...but should I at least dismiss this morph?
[choose no to leave everything unchanged]')
            ifFalse: [^ self]].

    super delete.
! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:07'!
deleteComponent
    model removeDependent: self.
    self pinsDo: [:pin | pin delete].
    ^ super delete! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 09:49'!
extent: newExtent
    super extent: newExtent.
    self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [m placeFromSpec]]! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/5/1998 00:57'!
initComponentIn: aLayout
    model _ aLayout model.
    self nameMeIn: aLayout.
    self color: Color lightCyan.
    self initPinSpecs.
    self initFromPinSpecs.
    self showPins.
    model addDependent: self! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/1/1998 16:31'!
initFromPinSpecs
    "no-op for default"! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:11'!
initPinSpecs
    "no-op for default"
    pinSpecs _ Array new.
! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:07'!
justDroppedInto: aMorph event: anEvent
    | theModel |
    theModel _ aMorph model.
    ((aMorph isKindOf: ComponentLayout)
        and: [theModel isKindOf: Component]) ifFalse:
        ["Disconnect prior to removal by move"
        (theModel isKindOf: Component) ifTrue: [self unwire.  model _ nil].
        ^ self].
    theModel == model ifTrue: [^ self  "Presumably just a move"].
    self initComponentIn: aMorph! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/26/1998 10:40'!
nameMeIn: aWorld
    | stem otherNames i partName className |
    className _ self class name.
    stem _ className.
    (stem size > 5 and: [stem endsWith: 'Morph'])
        ifTrue: [stem _ stem copyFrom: 1 to: stem size - 5].
    stem _ stem first asLowercase asString , stem allButFirst.
    otherNames _ Set newFrom: aWorld allKnownNames.
    i _ 1.
    [otherNames includes: (partName _ stem , i printString)]
        whileTrue: [i _ i + 1].
    self setNamePropertyTo: partName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 20:18'!
pinSpecs
    ^ pinSpecs! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/2/1998 15:09'!
pinsDo: pinBlock
    self submorphsDo: [:m | (m isKindOf: PinMorph) ifTrue: [pinBlock value: m]]! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 5/3/1998 09:26'!
renameMe
    | otherNames newName |
    otherNames _ Set newFrom: self pasteUpMorph allKnownNames.
    newName _ FillInTheBlank request: 'Please give this new a name'
                        initialAnswer: self knownName.
    newName isEmpty ifTrue: [^ nil].
    (otherNames includes: newName) ifTrue:
            [self inform: 'Sorry, that name is already used'. ^ nil].
    self setNamePropertyTo: newName! !

!ComponentLikeModel methodsFor: 'components' stamp: 'di 4/29/1998 15:16'!
showPins
    "Make up sensitized pinMorphs for each of my interface variables"
    self pinSpecs do: [:pinSpec | self addPinFromSpec: pinSpec]! !
MorphicTransform subclass: #CompositeTransform
    instanceVariableNames: 'globalTransform localTransform '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Support'!
!CompositeTransform commentStamp: 'di 5/22/1998 16:33' prior: 0!
A composite transform provides the effect of several levels of coordinate transformations.  This class is a subclass of MorphicTransform, only to inherit some generic transformation methods.  It would be better for both classes to inherit these methods from a common superclass.!


!CompositeTransform methodsFor: 'initialization' stamp: 'di 3/4/98 19:17'!
globalTransform: gt localTransform: lt
    globalTransform _ gt.
    localTransform _ lt! !


!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isIdentity
    ^ globalTransform isIdentity and: [localTransform isIdentity]! !

!CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'!
isPureTranslation
    ^ globalTransform isPureTranslation and: [localTransform isPureTranslation]! !


!CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'!
invert: aPoint
    ^ globalTransform invert: (localTransform transform: aPoint)! !

!CompositeTransform methodsFor: 'transformations' stamp: 'di 3/4/98 19:20'!
transform: aPoint
    ^ localTransform transform: (globalTransform transform: aPoint)! !
CharacterScanner subclass: #CompositionScanner
    instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace '
    classVariableNames: ''
    poolDictionaries: 'TextConstants '
    category: 'Graphics-Support'!
!CompositionScanner commentStamp: 'di 5/22/1998 16:33' prior: 0!
CompositionScanner comment:
'CompositionScanners are used to measure text and determine where line breaks and space padding should occur.'!


!CompositionScanner methodsFor: 'initialize-release'!
in: aParagraph
    "Initialize the paragraph to be scanned as the argument, aParagraph. Set
    the composition frame for the paragraph."

    super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle! !


!CompositionScanner methodsFor: 'accessing'!
rightX
    "Meaningful only when a line has just been composed -- refers to the
    line most recently composed. This is a subtrefuge to allow for easy
    resizing of a composition rectangle to the width of the maximum line.
    Useful only when there is only one line in the form or when each line
    is terminated by a carriage return. Handy for sizing menus and lists."

    ^spaceX! !


!CompositionScanner methodsFor: 'scanning' stamp: 'di 11/29/97 08:46'!
composeFrom: startIndex inRectangle: lineRectangle
    firstLine: firstLine leftSide: leftSide rightSide: rightSide
    "Answer an instance of TextLineInterval that represents the next line in the paragraph."
    | runLength done stopCondition |
    "Set up margins"
    leftMargin _ lineRectangle left.
    leftSide ifTrue: [leftMargin _ leftMargin +
                        (firstLine ifTrue: [textStyle firstIndent]
                                ifFalse: [textStyle restIndent])].
    spaceX _ destX _ leftMargin.
    rightMargin _ lineRectangle right.
    rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent].
    lastIndex _ startIndex.    "scanning sets last index"
    destY _ lineRectangle top.
    lineHeight _ baseline _ 0.  "Will be increased by setFont"
    self setStopConditions.    "also sets font"
    runLength _ text runLengthFor: startIndex.
    runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
    line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0)
                rectangle: lineRectangle;
                leftMargin: leftMargin.

    spaceCount _ 0.
    done _ false.
    [done]
        whileFalse:
            [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
                in: text string rightX: rightMargin stopConditions: stopConditions
                kern: kern displaying: false.
            "See setStopConditions for stopping conditions for composing."
            (self perform: stopCondition)
                ifTrue: [^ line lineHeight: lineHeight + textStyle leading
                            baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'di 10/29/97 12:17'!
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph
    "Answer an instance of TextLineInterval that represents the next line in the paragraph."
    | runLength done stopCondition |
    spaceX _ destX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
    destY _ 0.
    rightMargin _ aParagraph rightMarginForComposition.
    leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
    lastIndex _ startIndex.    "scanning sets last index"
    lineHeight _ textStyle lineGrid.  "may be increased by setFont:..."
    baseline _ textStyle baseline.
    self setStopConditions.    "also sets font"
    runLength _ text runLengthFor: startIndex.
    runStopIndex _ (lastIndex _ startIndex) + (runLength - 1).
    line _ TextLineInterval
        start: lastIndex
        stop: 0
        internalSpaces: 0
        paddingWidth: 0.
    spaceCount _ 0.
    done _ false.
    [done]
        whileFalse:
            [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
                in: text string rightX: rightMargin stopConditions: stopConditions
                kern: kern displaying: false.
            "See setStopConditions for stopping conditions for composing."
            (self perform: stopCondition)
                ifTrue: [^line lineHeight: lineHeight + textStyle leading
                            baseline: baseline + textStyle leading]]! !

!CompositionScanner methodsFor: 'scanning' stamp: 'di 10/24/97 09:15'!
setActualFont: aFont
    "Keep track of max height and ascent for auto lineheight"
    | descent |
    super setActualFont: aFont.
    lineHeight == nil
        ifTrue: [descent _ font descent.
                baseline _ font ascent.
                lineHeight _ baseline + descent]
        ifFalse: [descent _ lineHeight - baseline max: font descent.
                baseline _ baseline max: font ascent.
                lineHeight _ lineHeight max: baseline + descent]! !


!CompositionScanner methodsFor: 'stop conditions'!
cr
    "Answer true. Set up values for the text line interval currently being
    composed."

    line stop: lastIndex.
    spaceX _ destX.
    line paddingWidth: rightMargin - destX.
    ^true! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/10/97 10:35'!
crossedX
    "There is a word that has fallen across the right edge of the composition
    rectangle. This signals the need for wrapping which is done to the last
    space that was encountered, as recorded by the space stop condition."

    spaceCount >= 1 ifTrue:
        ["The common case. First back off to the space at which we wrap."
        line stop: spaceIndex.
        lineHeight _ lineHeightAtSpace.
        baseline _ baselineAtSpace.
        spaceCount _ spaceCount - 1.
        spaceIndex _ spaceIndex - 1.

        "Check to see if any spaces preceding the one at which we wrap.
            Double space after punctuation, most likely."
        [(spaceCount > 1 and: [(text at: spaceIndex) = Space])]
            whileTrue:
                [spaceCount _ spaceCount - 1.
                "Account for backing over a run which might
                    change width of space."
                font _ text fontAt: spaceIndex withStyle: textStyle.
                spaceIndex _ spaceIndex - 1.
                spaceX _ spaceX - (font widthOf: Space)].
        line paddingWidth: rightMargin - spaceX.
        line internalSpaces: spaceCount]
    ifFalse:
        ["Neither internal nor trailing spaces -- almost never happens."
        lastIndex _ lastIndex - 1.
        [destX <= rightMargin]
            whileFalse:
                [destX _ destX - (font widthOf: (text at: lastIndex)).
                lastIndex _ lastIndex - 1].
        spaceX _ destX.
        line paddingWidth: rightMargin - destX.
        line stop: (lastIndex max: line first)].
    ^true! !

!CompositionScanner methodsFor: 'stop conditions'!
endOfRun
    "Answer true if scanning has reached the end of the paragraph.
    Otherwise step conditions (mostly install potential new font) and answer
    false."

    | runLength |
    lastIndex = text size
    ifTrue:    [line stop: lastIndex.
            spaceX _ destX.
            line paddingWidth: rightMargin - destX.
            ^true]
    ifFalse:    [runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)).
            runStopIndex _ lastIndex + (runLength - 1).
            self setStopConditions.
            ^false]
! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/13/97 12:13'!
placeEmbeddedObject: anchoredMorph
    | descent |
    (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false].
    descent _ lineHeight - baseline.
    lineHeight _ lineHeight max: anchoredMorph height.
    baseline _ lineHeight - descent.
    ^ true! !

!CompositionScanner methodsFor: 'stop conditions'!
setStopConditions
    "Set the font and the stop conditions for the current run."

    self setFont! !

!CompositionScanner methodsFor: 'stop conditions' stamp: 'di 11/5/97 07:46'!
space
    "Record left x and character index of the space character just encounted.
    Used for wrap-around. Answer whether the character has crossed the
    right edge of the composition rectangle of the paragraph."

    spaceX _ destX.
    destX _ spaceX + spaceWidth.
    spaceIndex _ lastIndex.
    lineHeightAtSpace _ lineHeight.
    baselineAtSpace _ baseline.
    lastIndex _ lastIndex + 1.
    spaceCount _ spaceCount + 1.
    destX > rightMargin ifTrue:     [^self crossedX].
    ^false
! !

!CompositionScanner methodsFor: 'stop conditions'!
tab
    "Advance destination x according to tab settings in the paragraph's
    textStyle. Answer whether the character has crossed the right edge of
    the composition rectangle of the paragraph."

    destX _ textStyle
                nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin.
    destX > rightMargin ifTrue:    [^self crossedX].
    lastIndex _ lastIndex + 1.
    ^false
! !
AlignmentMorph subclass: #CompoundTileMorph
    instanceVariableNames: 'type testPart yesPart noPart '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Scripting-Tiles'!
!CompoundTileMorph commentStamp: 'di 5/22/1998 16:33' prior: 0!
CompoundTileMorph comment:
'A statement with other whole statements inside it.  If-Then.  Test.'!


!CompoundTileMorph methodsFor: 'all'!
acceptDroppingMorph: aMorph event: evt
    "Forward the dropped morph to the appropriate part."

    (self targetPartFor: aMorph) acceptDroppingMorph: aMorph event: evt.
! !

!CompoundTileMorph methodsFor: 'all'!
codeString

    | s |
    s _ WriteStream on: ''.
    self storeCodeOn: s.
    ^ s contents
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 21:31'!
enclosingEditor
    "Return the next scriptor outward in the containment hierarchy"
    | current |
    current _ owner.
    [current == nil] whileFalse:
        [((current isKindOf: ScriptEditorMorph)
                or: [current isKindOf: CompoundTileMorph])
            ifTrue: [^ current].
        current _ current owner].
    ^ nil! !

!CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 21:36'!
handlesMouseOver: evt

    ^ true
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 5/13/1998 14:49'!
initialize

    | r |
    super initialize.
    self color: Color orange muchLighter.
    self borderWidth: 1.
    self inset: 2.
    self orientation: #vertical.

    r _ AlignmentMorph newRow color: color; inset: 0.
    r setProperty: #demandsBoolean toValue: true.
    r addMorphBack: (Morph new color: color; extent: 2@5).  "spacer"
    r addMorphBack: (StringMorph new contents: 'Test').
    r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
    r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; inset: 1).
    testPart color: Color transparent.
    self addMorphBack: r.

    r _ AlignmentMorph newRow color: color; inset: 0.
    r addMorphBack: (Morph new color: color; extent: 30@5).  "spacer"
    r addMorphBack: (StringMorph new contents: 'Yes').
    r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
    r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; inset: 2).
    yesPart color: Color transparent.
    self addMorphBack: r.

    r _ AlignmentMorph newRow color: color; inset: 0.
    r addMorphBack: (Morph new color: color; extent: 35@5).  "spacer"
    r addMorphBack: (StringMorph new contents: 'No').
    r addMorphBack: (Morph new color: color; extent: 5@5).  "spacer"
    r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; inset: 2).
    noPart color: Color transparent.
    self addMorphBack: r.

    self extent: 5@5.  "will grow to fit"
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/18/97 18:03'!
install
    "Backstop for obscure cases"! !

!CompoundTileMorph methodsFor: 'all' stamp: 'tk 10/1/97 18:25'!
isTileLike
    "Can be dropped into a script"
    ^ true! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:25'!
markEdited
    "Pertains only when the test is outside a script?!!"
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'jm 10/18/97 21:03'!
mouseEnter: evt
    "Resume drop-tracking in enclosing editor"
    | ed |
    (ed _ self enclosingEditor) ifNotNil:
        [ed mouseLeave: evt]! !

!CompoundTileMorph methodsFor: 'all' stamp: 'jm 10/18/97 21:02'!
mouseLeave: evt
    "Resume drop-tracking in enclosing editor"
    | ed |
    (ed _ self enclosingEditor) ifNotNil:
        [ed mouseEnter: evt]! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 2/16/98 03:40'!
player
    ^ nil! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 2/1/98 16:40'!
prepareToUndoDropOf: aMorph
    "needs to be here, as a no-op, owing to being hit obscurely on occasion"! !

!CompoundTileMorph methodsFor: 'all' stamp: 'di 10/17/97 16:31'!
resultType
    ^ #command! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 5/13/1998 15:19'!
rowOfRightTypeFor: aLayoutMorph forActor: anActor
    aLayoutMorph demandsBoolean ifTrue:
        [^ self error: 'oops, cannot do that, please close this'].
    ^ self! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:23'!
scriptEdited
     "Pertains only when the test is outside a script?!!"! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 21:23'!
scriptee
     "Pertains only when the test is outside a script?!!"
    ^ nil! !

!CompoundTileMorph methodsFor: 'all' stamp: 'jm 11/3/97 16:37'!
storeCodeBlockFor: scriptPart on: aStream

    | lastTile |
    lastTile _ nil.
    scriptPart allMorphsDo: [:m |
        (m isKindOf: TileMorph) ifTrue: [
            (self tile: m isOnLineAfter: lastTile) ifTrue: [
                lastTile ~~ nil ifTrue: [aStream nextPut: $.; cr].
                aStream tab; tab.
            ] ifFalse: [
                (lastTile ~= nil) ifTrue: [aStream space]].
            m storeCodeOn: aStream.
            lastTile _ m]].
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'jm 11/3/97 16:30'!
storeCodeOn: aStream

    aStream nextPut: $(.
    testPart storeCodeOn: aStream.
    aStream nextPut: $); cr; tab; nextPutAll: 'ifTrue: ['; cr.
    self storeCodeBlockFor: yesPart on: aStream.
    aStream nextPut: $]; cr; tab; nextPutAll: 'ifFalse: ['; cr.
    self storeCodeBlockFor: noPart on: aStream.
    aStream nextPut: $]; cr.
! !

!CompoundTileMorph methodsFor: 'all'!
targetPartFor: aMorph
    "Return the row into which the given morph should be inserted."

    | centerY |
    centerY _ aMorph fullBounds center y.
    (Array with: testPart with: yesPart with: noPart) do: [:m |
        (centerY <= m bounds bottom) ifTrue: [^ m]].
    ^ noPart
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'di 5/6/1998 21:10'!
tile: tile isOnLineAfter: previousTile
    "Return true if the given tile is not on the same line at the previous tile or if the previous tile is nil."

    | tileRow previousRow |
    previousTile ifNil: [^ true].
    tileRow _ tile owner.
    [tileRow isMemberOf: AlignmentMorph]
        whileFalse: [tileRow _ tileRow owner].  "find the owning row"
    previousRow _ previousTile owner.
    [previousRow isMemberOf: AlignmentMorph]
        whileFalse: [previousRow _ previousRow owner].  "find the owning row"
    ^ tileRow ~~ previousRow
! !

!CompoundTileMorph methodsFor: 'all' stamp: 'tk 10/10/97 17:28'!
tileRows
    "See if this works for insertion"
    ^ Array with: (Array with: self fullCopy)! !

!CompoundTileMorph methodsFor: 'all' stamp: 'sw 10/13/97 20:25'!
topEditor
    | editor |
    editor _ self outermostMorphThat: [:m | (m isKindOf: ScriptEditorMorph) or:
         [m isKindOf: CompoundTileMorph]].
    ^ editor ifNil: [self] ifNotNil: [editor]! !

!CompoundTileMorph methodsFor: 'all'!
type

    ^ #compound
! !

!CompoundTileMorph methodsFor: 'all'!
wantsDroppedMorph: aMorph event: evt

    ^ (aMorph isKindOf: TileMorph) or:
       [(aMorph isKindOf: ScriptEditorMorph) or:
       [(aMorph isKindOf: CompoundTileMorph) or:
       [aMorph isKindOf: CommandTilesMorph]]]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CompoundTileMorph class
    instanceVariableNames: ''!

!CompoundTileMorph class methodsFor: 'instance creation' stamp: 'di 6/22/97 09:07'!
includeInNewMorphMenu
    "Not to be instantiated from the menu"
    ^ false! !
Object subclass: #ConnectionQueue
    instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'System-Network'!
!ConnectionQueue commentStamp: 'di 5/22/1998 16:33' prior: 0!
A ConnectionQueue listens on a given port number and collects a queue of client connections. In order to handle state changes quickly, a ConnectionQueue has its own process that: (a) tries to keep a socket listening on the port whenever the queue isn't already full of connections and (b) prunes stale connections out of the queue to make room for fresh ones.
!


!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 17:31'!
connectionCount
    "Return an estimate of the number of currently queued connections. This is only an estimate since a new connection could be made, or an existing one aborted, at any moment."

    | count |
    self pruneStaleConnections.
    accessSema critical: [count _ connections size].
    ^ count
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/9/98 14:34'!
destroy
    "Terminate the listener process and destroy all sockets in my possesion."

    process ifNotNil: [
        process terminate.
        process _ nil].
    socket ifNotNil: [
        socket destroy.
        socket _ nil].
    connections do: [:s | s destroy].
    connections _ OrderedCollection new.
! !

!ConnectionQueue methodsFor: 'public' stamp: 'jm 3/10/98 09:18'!
getConnectionOrNil
    "Return a connected socket, or nil if no connection has been established."

    | result |
    accessSema critical: [
        connections isEmpty
            ifTrue: [result _ nil]
            ifFalse: [
                result _ connections removeFirst.
                ((result isValid) and: [result isConnected]) ifFalse: [  "stale connection"
                    result destroy.
                    result _ nil]]].
    ^ result
! !


!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 11:07'!
initPortNumber: anInteger queueLength: queueLength
    "Private!! Initialize the receiver to listen on the given port number. Up to queueLength connections will be queued."

    portNumber _ anInteger.
    maxQueueLength _ queueLength.
    connections _ OrderedCollection new.
    accessSema _ Semaphore forMutualExclusion.
    socket _ nil.
    process _ [self listenLoop] newProcess.
    process priority: Processor highIOPriority.
    process resume.
! !

!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/13/98 14:31'!
listenLoop
    "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port."
    "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection."

    [true] whileTrue: [
        ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [
            "try to create a new socket for listening"
            socket _ Socket createIfFail: [nil]].

        socket == nil
            ifTrue: [(Delay forMilliseconds: 100) wait]
            ifFalse: [
                socket isUnconnected ifTrue: [socket listenOn: portNumber].
                socket waitForConnectionUntil: (Socket deadlineSecs: 10).
                socket isConnected
                    ifTrue: [  "connection established"
                        accessSema critical: [connections addLast: socket].
                        socket _ nil]
                    ifFalse: [
                        (socket isWaitingForConnection or:
                         [socket isUnconnected])
                            ifFalse: [socket destroy. socket _ nil]]].  "return to unconnected state"

        self pruneStaleConnections].
! !

!ConnectionQueue methodsFor: 'private' stamp: 'jm 3/10/98 17:30'!
pruneStaleConnections
    "Private!! The client may establish a connection and then disconnect while it is still in the connection queue. This method is called periodically to prune such sockets out of the connection queue and make room for fresh connections."

    | foundStaleConnection |
    accessSema critical: [
        foundStaleConnection _ false.
        connections do: [:s |
            s isUnconnected ifTrue: [
                s destroy.
                foundStaleConnection _ true]].
        foundStaleConnection ifTrue: [
            connections _ connections select: [:s | s isValid]]].
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ConnectionQueue class
    instanceVariableNames: ''!

!ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'!
portNumber: anInteger queueLength: queueLength

    ^ self new initPortNumber: anInteger queueLength: queueLength
! !
InstructionStream subclass: #ContextPart
    instanceVariableNames: 'stackp '
    classVariableNames: 'TryPrimitiveMethods TryPrimitiveSelectors '
    poolDictionaries: ''
    category: 'Kernel-Methods'!
!ContextPart commentStamp: 'di 5/22/1998 16:33' prior: 0!
ContextPart comment:
'To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.

The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
    Transcript show: (ContextPart runSimulated: [3 factorial]) printString.'!


!ContextPart methodsFor: 'accessing'!
client
    "Answer the client, that is, the object that sent the message that created this context."

    ^sender receiver! !

!ContextPart methodsFor: 'accessing'!
home
    "Answer the context in which the receiver was defined."

    self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
method
    "Answer the method of this context."

    self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
receiver
    "Answer the receiver of the message that created this context."

    self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index
    "Answer the value of the temporary variable whose index is the
    argument, index."

    self subclassResponsibility! !

!ContextPart methodsFor: 'accessing'!
tempAt: index put: value
    "Store the argument, value, as the temporary variable whose index is the
    argument, index."

    self subclassResponsibility! !


!ContextPart methodsFor: 'instruction decoding'!
doDup
    "Simulate the action of a 'duplicate top of stack' bytecode."

    self push: self top! !

!ContextPart methodsFor: 'instruction decoding'!
doPop
    "Simulate the action of a 'remove top of stack' bytecode."

    self pop! !

!ContextPart methodsFor: 'instruction decoding'!
jump: distance
    "Simulate the action of a 'unconditional jump' bytecode whose offset is
    the argument, distance."

    pc _ pc + distance! !

!ContextPart methodsFor: 'instruction decoding'!
jump: distance if: condition
    "Simulate the action of a 'conditional jump' bytecode whose offset is the
    argument, distance, and whose condition is the argument, condition."

    (self pop eqv: condition) ifTrue: [self jump: distance]! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnConstant: value
    "Simulate the action of a 'return constant' bytecode whose value is the
    argument, value. This corresponds to a source expression like '^0'."

    ^self return: value to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnReceiver
    "Simulate the action of a 'return receiver' bytecode. This corresponds to
    the source expression '^self'."

    ^self return: self receiver to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
methodReturnTop
    "Simulate the action of a 'return top of stack' bytecode. This corresponds
    to source expressions like '^something'."

    ^self return: self pop to: self home sender! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value
    "Simulate the action of bytecode that removes the top of the stack and
    stores it into a literal variable of my method."

    value value: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset
    "Simulate the action of bytecode that removes the top of the stack and
    stores it into an instance variable of my receiver."

    self receiver instVarAt: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset
    "Simulate the action of bytecode that removes the top of the stack and
    stores it into one of my temporary variables."

    self home at: offset + 1 put: self pop! !

!ContextPart methodsFor: 'instruction decoding'!
pushActiveContext
    "Simulate the action of bytecode that pushes the the active context on the
    top of its own stack."

    self push: self! !

!ContextPart methodsFor: 'instruction decoding'!
pushConstant: value
    "Simulate the action of bytecode that pushes the constant, value, on the
    top of the stack."

    self push: value! !

!ContextPart methodsFor: 'instruction decoding'!
pushLiteralVariable: value
    "Simulate the action of bytecode that pushes the contents of the literal
    variable whose index is the argument, index, on the top of the stack."

    self push: value value! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiver
    "Simulate the action of bytecode that pushes the active context's receiver
    on the top of the stack."

    self push: self receiver! !

!ContextPart methodsFor: 'instruction decoding'!
pushReceiverVariable: offset
    "Simulate the action of bytecode that pushes the contents of the receiver's
    instance variable whose index is the argument, index, on the top of the
    stack."

    self push: (self receiver instVarAt: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding'!
pushTemporaryVariable: offset
    "Simulate the action of bytecode that pushes the contents of the
    temporary variable whose index is the argument, index, on the top of
    the stack."

    self push: (self home at: offset + 1)! !

!ContextPart methodsFor: 'instruction decoding' stamp: 'sn 8/21/97 22:15'!
send: selector super: superFlag numArgs: numArgs
    "Simulate the action of bytecodes that send a message with selector,
    selector. The argument, superFlag, tells whether the receiver of the
    message was specified with 'super' in the source method. The arguments
    of the message are found in the top numArgs locations on the stack and
    the receiver just below them."

    | receiver arguments answer |
    arguments _ Array new: numArgs.
    numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop].
    receiver _ self pop.
    (selector == #halt or: [selector == #halt:]) ifTrue:
        [self error: 'Cant simulate halt.  Proceed to bypass it.'.
        self push: nil. ^self].
    selector == #doPrimitive:receiver:args:
        ifTrue: [answer _ receiver
                    doPrimitive: (arguments at: 1)
                    receiver: (arguments at: 2)
                    args: (arguments at: 3).
                self push: answer.
                ^self].
    ^self send: selector to: receiver with: arguments super: superFlag! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoLiteralVariable: value
    "Simulate the action of bytecode that stores the top of the stack into a
    literal variable of my method."

    value value: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoReceiverVariable: offset
    "Simulate the action of bytecode that stores the top of the stack into an
    instance variable of my receiver."

    self receiver instVarAt: offset + 1 put: self top! !

!ContextPart methodsFor: 'instruction decoding'!
storeIntoTemporaryVariable: offset
    "Simulate the action of bytecode that stores the top of the stack into one
    of my temporary variables."

    self home at: offset + 1 put: self top! !


!ContextPart methodsFor: 'debugger access'!
depthBelow: aContext
    "Answer how many calls there are between this and aContext."

    | this depth |
    this _ self.
    depth _ 0.
    [this == aContext or: [this == nil]]
        whileFalse:
            [this _ this sender.
            depth _ depth + 1].
    ^depth! !

!ContextPart methodsFor: 'debugger access'!
mclass
    "Answer the class in which the receiver's method was found."

    self receiver class selectorAtMethod: self method setClass: [:mclass].
    ^mclass! !

!ContextPart methodsFor: 'debugger access'!
pc
    "Answer the index of the next bytecode to be executed."

    ^pc! !

!ContextPart methodsFor: 'debugger access'!
release
    "Remove information from the receiver and all of the contexts on its
    sender chain in order to break circularities."

    self releaseTo: nil! !

!ContextPart methodsFor: 'debugger access'!
releaseTo: caller
    "Remove information from the receiver and the contexts on its sender
    chain up to caller in order to break circularities."

    | c s |
    c _ self.
    [c == nil or: [c == caller]]
        whileFalse:
            [s _ c sender.
            c singleRelease.
            c _ s]! !

!ContextPart methodsFor: 'debugger access'!
selector
    "Answer the selector of the method that created the receiver."

    ^self receiver class
        selectorAtMethod: self method
        setClass: [:ignored]! !

!ContextPart methodsFor: 'debugger access'!
sender
    "Answer the context that sent the message that created the receiver."

    ^sender! !

!ContextPart methodsFor: 'debugger access' stamp: 'tk 4/16/1998 12:00'!
shortStack
    "Answer a String showing the top four contexts on my sender chain."
    | shortStackStream |
    shortStackStream _ WriteStream on: (String new: 55*10).
    (self stackOfSize: 10) do:
        [:item | shortStackStream print: item; cr].
    ^shortStackStream contents! !

!ContextPart methodsFor: 'debugger access'!
singleRelease
    "Remove information from the receiver in order to break circularities."

    stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]].
    sender _ nil! !

!ContextPart methodsFor: 'debugger access'!
sourceCode
    | selector methodClass |
    selector _ self receiver class selectorAtMethod: self method
        setClass: [:mclass | methodClass _ mclass].
    ^ methodClass sourceCodeAt: selector! !

!ContextPart methodsFor: 'debugger access'!
stack
    "Answer an Array of the contexts on the receiver's sender chain."

    ^self stackOfSize: 9999! !

!ContextPart methodsFor: 'debugger access'!
stackOfSize: limit
    "Answer an OrderedCollection of the top 'limit' contexts
        on the receiver's sender chain."

    | a stack |
    stack _ OrderedCollection new.
    stack addLast: (a _ self).
    [(a _ a sender) ~~ nil and: [stack size < limit]]
        whileTrue: [stack addLast: a].
    ^ stack! !

!ContextPart methodsFor: 'debugger access'!
swapSender: coroutine
    "Replace the receiver's sender with coroutine and answer the receiver's
    previous sender. For use in coroutining."

    | oldSender |
    oldSender _ sender.
    sender _ coroutine.
    ^oldSender! !

!ContextPart methodsFor: 'debugger access'!
tempNames
    "Answer an OrderedCollection of the names of the receiver's temporary
    variables, which are strings."

    self method setTempNamesIfCached: [:names | ^names].
    names _ (self mclass compilerClass new
            parse: self sourceCode
            in: self mclass
            notifying: nil) tempNames.
    self method cacheTempNames: names.
    ^names! !

!ContextPart methodsFor: 'debugger access'!
tempsAndValues
    "Return a string of the temporary variabls and their current values"
    | aStream |
    aStream _ WriteStream on: (String new: 100).
    self tempNames
        doWithIndex: [:title :index |
            aStream nextPutAll: title; nextPut: $:; space; tab.
            (self tempAt: index) printOn: aStream.
            aStream cr].
    ^aStream contents! !


!ContextPart methodsFor: 'controlling'!
activateMethod: newMethod withArgs: args receiver: rcvr class: class
    "Answer a ContextPart initialized with the arguments."

    ^MethodContext
        sender: self
        receiver: rcvr
        method: newMethod
        arguments: args! !

!ContextPart methodsFor: 'controlling'!
blockCopy: numArgs
    "Primitive. Distinguish a block of code from its enclosing method by
    creating a new BlockContext for that block. The compiler inserts into all
    methods that contain blocks the bytecodes to send the message
    blockCopy:. Do not use blockCopy: in code that you write!! Only the
    compiler can decide to send the message blockCopy:. Fail if numArgs is
    not a SmallInteger. Optional. No Lookup. See Object documentation
    whatIsAPrimitive."

    <primitive: 80>
    ^(BlockContext new: self size)
        home: self home
        startpc: pc + 2
        nargs: numArgs! !

!ContextPart methodsFor: 'controlling'!
hasSender: context
    "Answer whether the receiver is strictly above context on the stack."

    | s |
    self == context ifTrue: [^false].
    s _ sender.
    [s == nil]
        whileFalse:
            [s == context ifTrue: [^true].
            s _ s sender].
    ^false! !

!ContextPart methodsFor: 'controlling'!
pop
    "Answer the top of the receiver's stack and remove the top of the stack."

    | val |
    val _ self at: stackp.
    self at: stackp put: nil.
    stackp _ stackp - 1.
    ^val! !

!ContextPart methodsFor: 'controlling'!
push: val
    "Push val on the receiver's stack."

    self at: (stackp _ stackp + 1) put: val! !

!ContextPart methodsFor: 'controlling'!
return: value to: sendr
    "Simulate the return of value to sendr."

    self releaseTo: sendr.
    ^sendr push: value! !

!ContextPart methodsFor: 'controlling'!
send: selector to: rcvr with: args super: superFlag
    "Simulate the action of sending a message with selector, selector, and
    arguments, args, to receiver. The argument, superFlag, tells whether the
    receiver of the message was specified with 'super' in the source method."

    | class meth val |
    class _
        superFlag
            ifTrue: [(self method literalAt: self method numLiterals) value superclass]
            ifFalse: [rcvr class].
    [class == nil]
        whileFalse:
            [(class includesSelector: selector)
                ifTrue:
                    [meth _ class compiledMethodAt: selector.
                    val _
                        self tryPrimitiveFor: meth
                            receiver: rcvr
                            args: args.
                    val == #simulatorFail ifFalse: [^val].
                    (selector == #doesNotUnderstand: and: [class == Object]) ifTrue:
                        [ ^ self error: 'Simulated message ' , (args at: 1) selector , ' not understood' ].
                    ^self
                        activateMethod: meth
                        withArgs: args
                        receiver: rcvr
                        class: class].
            class _ class superclass].
    ^self send: #doesNotUnderstand:
        to: rcvr
        with: (Array with: (Message selector: selector arguments: args))
        super: superFlag! !

!ContextPart methodsFor: 'controlling'!
top
    "Answer the top of the receiver's stack."

    ^self at: stackp! !


!ContextPart methodsFor: 'printing'!
printOn: aStream
    | selector class |
    selector _
        (class _ self receiver class)
            selectorAtMethod: self method
            setClass: [:mclass].
    selector == #?
        ifTrue:
            [aStream nextPut: $?; print: self method who.
            ^self].
    aStream nextPutAll: class name.
    mclass == class
        ifFalse:
            [aStream nextPut: $(.
            aStream nextPutAll: mclass name.
            aStream nextPut: $)].
    aStream nextPutAll: '>>'.
    aStream nextPutAll: selector! !


!ContextPart methodsFor: 'system simulation' stamp: 'di 1/5/98 11:20'!
completeCallee: aContext
    "Simulate the execution of bytecodes until a return to the receiver."
    | ctxt current |
    ctxt _ aContext.
    [ctxt == current or: [ctxt hasSender: self]]
        whileTrue:
            [current _ ctxt.
            ctxt _ ctxt step].
    self stepToSendOrReturn! !

!ContextPart methodsFor: 'system simulation' stamp: 'di 1/5/98 11:20'!
runSimulated: aBlock contextAtEachStep: block2
    "Simulate the execution of the argument, aBlock, until it ends. aBlock
    MUST NOT contain an '^'. Evaluate block2 with the current context
    prior to each instruction executed. Answer the simulated value of aBlock."
    | current |
    aBlock hasMethodReturn
        ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
    current _ aBlock.
    current pushArgs: Array new from: self.
    [current == self]
        whileFalse:
            [block2 value: current.
            current _ current step].
    ^self pop! !

!ContextPart methodsFor: 'system simulation'!
step
    "Simulate the execution of the receiver's next bytecode. Answer the
    context that would be the active context after this bytecode."

    ^self interpretNextInstructionFor: self! !

!ContextPart methodsFor: 'system simulation' stamp: 'sn 8/22/97 21:55'!
stepToSendOrReturn
    "Simulate the execution of bytecodes until either sending a message or
    returning a value to the receiver (that is, until switching contexts)."

    [self willReallySend | self willReturn]
        whileFalse: [self step]! !


!ContextPart methodsFor: 'private' stamp: 'di 1/4/98 23:16'!
doPrimitive: primitiveIndex receiver: receiver args: arguments
    "Simulate a primitive method whose index is primitiveIndex.  The
    simulated receiver and arguments are given as arguments to this message."
"
    NOTE: In order for perform:WithArguments: to work reliably here,
    this method must be forced to invoke a large context.  This is done
    by adding extra temps until the following expression evaluates as true:
        (ContextPart compiledMethodAt: #doPrimitive:receiver:args:) frameSize > 20
"
    | value t1 t2 t3 |
    "If successful, push result and return resuming context,
        else ^ #simulatorFail"
    (primitiveIndex = 80 and: [receiver isKindOf: ContextPart])
        ifTrue: [^self push:
                    ((BlockContext new: receiver size)
                        home: receiver home
                        startpc: pc + 2
                        nargs: (arguments at: 1))].
    (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])
        ifTrue: [^receiver pushArgs: arguments from: self].
    primitiveIndex = 83
        ifTrue: [^ self send: arguments first to: receiver
                    with: arguments allButFirst
                    super: false].
    arguments size > 6 ifTrue: [^#simulatorFail].
    value _ receiver tryPrimitive: primitiveIndex withArgs: arguments.
    value == #simulatorFail
        ifTrue: [^ #simulatorFail]
        ifFalse: [^ self push: value]! !

!ContextPart methodsFor: 'private'!
pop: numObjects toAddable: anAddableCollection
    "Pop the top numObjects elements from the stack, and store them in
     anAddableCollection, topmost element last.
     Do not call directly.  Called indirectly by {1. 2. 3} constructs."

    | oldTop i |
    i _ stackp _ (oldTop _ stackp) - numObjects.
    [(i _ i + 1) <= oldTop] whileTrue:
        [anAddableCollection add: (self at: i).
         self at: i put: nil]! !

!ContextPart methodsFor: 'private'!
pop: numObjects toIndexable: anIndexableCollection
    "Pop the top numObjects elements from the stack, and store them in
     anIndexableCollection, topmost element last.
     Do not call directly.  Called indirectly by {1. 2. 3} constructs."

    | oldTop i |
    i _ stackp _ (oldTop _ stackp) - numObjects.
    [(i _ i + 1) <= oldTop] whileTrue:
        [anIndexableCollection at: i-stackp put: (self at: i).
         self at: i put: nil]! !

!ContextPart methodsFor: 'private'!
push: numObjects fromIndexable: anIndexableCollection
    "Push the elements of anIndexableCollection onto the receiver's stack.
     Do not call directly.  Called indirectly by {1. 2. 3} constructs."

    | i |
    i _ 0.
    [(i _ i + 1) <= numObjects] whileTrue:
        [self at: (stackp _ stackp + 1) put: (anIndexableCollection at: i)]! !

!ContextPart methodsFor: 'private'!
stackPtr  "For use only by the SystemTracer"
    ^ stackp! !

!ContextPart methodsFor: 'private'!
tryPrimitiveFor: method receiver: receiver args: arguments
    "Simulate a primitive method, method for the receiver and arguments given
    as arguments to this message.  Answer resuming the context if successful, else
    answer the symbol, #simulatorFail."
    | flag primIndex |
    (primIndex _ method primitive) = 0 ifTrue: [^#simulatorFail].
    ^ self doPrimitive: primIndex receiver: receiver args: arguments! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ContextPart class
    instanceVariableNames: ''!

!ContextPart class methodsFor: 'examples'!
tallyInstructions: aBlock
    "This method uses the simulator to count the number of occurrences of
    each of the Smalltalk instructions executed during evaluation of aBlock.
    Results appear in order of the byteCode set."
    | tallies |
    tallies _ Bag new.
    thisContext sender
        runSimulated: aBlock
        contextAtEachStep:
            [:current | tallies add: current nextByte].
    ^tallies sortedElements

    "ContextPart tallyInstructions: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples'!
tallyMethods: aBlock
    "This method uses the simulator to count the number of calls on each method
    invoked in evaluating aBlock. Results are given in order of decreasing counts."
    | prev tallies |
    tallies _ Bag new.
    prev _ aBlock.
    thisContext sender
        runSimulated: aBlock
        contextAtEachStep:
            [:current |
            current == prev ifFalse: "call or return"
                [prev sender == nil ifFalse: "call only"
                    [tallies add: current printString].
                prev _ current]].
    ^tallies sortedCounts

    "ContextPart tallyMethods: [3.14159 printString]"! !

!ContextPart class methodsFor: 'examples'!
trace: aBlock        "ContextPart trace: [3 factorial]"
    "This method uses the simulator to print calls and returned values in the Transcript."
    | prev |
    Transcript clear.
    prev _ aBlock.
    ^ thisContext sender
        runSimulated: aBlock
        contextAtEachStep:
            [:current |
            Sensor anyButtonPressed ifTrue: [^ nil].
            current == prev
                ifFalse:
                    [prev sender == nil ifTrue:  "returning"
                        [Transcript space; nextPut: $^; print: current top].
                    Transcript cr;
                        nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );
                        print: current receiver; space; nextPutAll: current selector; endEntry.
                    prev _ current]]! !

!ContextPart class methodsFor: 'examples'!
trace: aBlock onFileNamed: fileName        "ContextPart trace: [3 factorial]"
    "This method uses the simulator to print calls to a file."
    | prev f sel |
    f _ FileStream fileNamed: fileName.
    prev _ aBlock.
    thisContext sender
        runSimulated: aBlock
        contextAtEachStep:
            [:current |
            Sensor anyButtonPressed ifTrue: [^ nil].
            current == prev
                ifFalse:
                    [f cr;
                        nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );
                        print: current receiver class; space; nextPutAll: (sel _ current selector); flush.
                    prev _ current.
                    sel == #error: ifTrue: [self halt]]].
    f close! !


!ContextPart class methodsFor: 'simulation'!
runSimulated: aBlock
    "Simulate the execution of the argument, current. Answer the result it
    returns."

    ^ thisContext sender
        runSimulated: aBlock
        contextAtEachStep: [:ignored]

    "ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! !
Inspector subclass: #ContextVariablesInspector
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Debugger'!
!ContextVariablesInspector commentStamp: 'di 5/22/1998 16:33' prior: 0!
ContextVariablesInspector comment:
'I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.'!


!ContextVariablesInspector methodsFor: 'accessing'!
fieldList
    "Refer to the comment in Inspector|fieldList."

    object == nil ifTrue: [^Array with: 'thisContext'].
    ^(Array with: 'thisContext' with: 'all temp vars') , object tempNames! !

!ContextVariablesInspector methodsFor: 'accessing' stamp: 'sw 9/12/97 21:47'!
selectedSlotName
     ^ object tempNames at: (self selectionIndex - 2)! !


!ContextVariablesInspector methodsFor: 'selecting'!
replaceSelectionValue: anObject
    "Refer to the comment in Inspector|replaceSelectionValue:."

    selectionIndex = 1
        ifTrue: [^object]
        ifFalse: [^object tempAt: selectionIndex - 2 put: anObject]! !

!ContextVariablesInspector methodsFor: 'selecting'!
selection
    "Refer to the comment in Inspector|selection."

    selectionIndex = 1 ifTrue: [^object].
    selectionIndex = 2
        ifTrue: [^object tempsAndValues]
        ifFalse: [^object tempAt: selectionIndex - 2]! !


!ContextVariablesInspector methodsFor: 'code'!
doItContext

    ^object! !

!ContextVariablesInspector methodsFor: 'code'!
doItReceiver

    ^object receiver! !
Object subclass: #ControlManager
    instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController newTopClicked '
    classVariableNames: 'CmdDotEnabled '
    poolDictionaries: ''
    category: 'Interface-Framework'!
!ControlManager commentStamp: 'di 5/22/1998 16:33' prior: 0!
ControlManager comment:
'I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.'!


!ControlManager methodsFor: 'initialize-release'!
initialize
    "Initialize the receiver to refer to only the background controller."
    | screenView |
    screenController _ ScreenController new.
    screenView _ FormView new.
    screenView model: (InfiniteForm with: Color gray) controller: screenController.
    screenView window: Display boundingBox.
    scheduledControllers _ OrderedCollection with: screenController! !

!ControlManager methodsFor: 'initialize-release'!
release
    "Refer to the comment in Object|release."

    scheduledControllers == nil
        ifFalse:
            [scheduledControllers
                do: [:controller | (controller isKindOf: Controller)
                                ifTrue: [controller view release]
                                ifFalse: [controller release]].
            scheduledControllers _ nil]! !


!ControlManager methodsFor: 'accessing'!
activeController
    "Answer the currently active controller."

    ^activeController! !

!ControlManager methodsFor: 'accessing'!
activeController: aController
    "Set aController to be the currently active controller. Give the user
    control in it."

    activeController _ aController.
    (activeController == screenController)
        ifFalse: [self promote: activeController].
    activeControllerProcess _
            [activeController startUp.
            self searchForActiveController] newProcess.
    activeControllerProcess priority: Processor userSchedulingPriority.
    activeControllerProcess resume! !

!ControlManager methodsFor: 'accessing'!
activeControllerNoTerminate: aController andProcess: aProcess
    "Set aController to be the currently active controller and aProcess to be
    the the process that handles controller scheduling activities in the
    system. This message differs from activeController:andProcess: in that it
    does not send controlTerminate to the currently active controller."

    self inActiveControllerProcess
        ifTrue:
            [aController~~nil
                ifTrue: [(scheduledControllers includes: aController)
                            ifTrue: [self promote: aController]
                            ifFalse: [self error: 'Old controller not scheduled']].
            activeController _ aController.
            activeController == nil
                ifFalse: [activeController controlInitialize].
            activeControllerProcess _ aProcess.
            activeControllerProcess resume]
        ifFalse:
            [self error: 'New active controller process must be set from old one'] ! !

!ControlManager methodsFor: 'accessing'!
activeControllerProcess
    "Answer the process that is currently handling controller scheduling
    activities in the system."

    ^activeControllerProcess! !

!ControlManager methodsFor: 'accessing'!
controllerSatisfying: aBlock
    "Return the first scheduled controller which satisfies the 1-argument boolean-valued block, or nil if none.  7/25/96 sw"

    scheduledControllers do:
        [:aController | (aBlock value: aController) == true ifTrue: [^ aController]].
    ^ nil! !

!ControlManager methodsFor: 'accessing' stamp: 'sw 9/27/96'!
controllersSatisfying: aBlock
    "Return a list of scheduled controllers satisfying aBlock.  "

    ^ scheduledControllers select:
        [:aController | (aBlock value: aController) == true]! !

!ControlManager methodsFor: 'accessing'!
controllerWhoseModelSatisfies: aBlock
    "Return the first scheduled controller whose model satisfies the 1-argument boolean-valued block, or nil if none.  5/6/96 sw"

    scheduledControllers do:
        [:aController | (aBlock value: aController model) == true ifTrue: [^ aController]].
    ^ nil! !

!ControlManager methodsFor: 'accessing'!
includes: aController
    ^ scheduledControllers includes: aController! !

!ControlManager methodsFor: 'accessing'!
noteNewTop
    newTopClicked _ true! !

!ControlManager methodsFor: 'accessing' stamp: 'sw 10/9/96'!
removeAllControllersSatisfying: aBlock
    "Unschedule and delete all controllers satisfying aBlock.  May not leave the screen exactly right sometimes. "

    (self controllersSatisfying:  aBlock) do:
        [:aController | aController closeAndUnschedule]! !

!ControlManager methodsFor: 'accessing'!
scheduledControllers
    "Answer a copy of the ordered collection of scheduled controllers."

    ^scheduledControllers copy! !

!ControlManager methodsFor: 'accessing' stamp: 'di 10/4/97 09:05'!
scheduledWindowControllers
    "Same as scheduled controllers, but without ScreenController.
    Avoids null views just after closing, eg, a debugger."

    ^ scheduledControllers select:
        [:c | c ~~ screenController and: [c view ~~ nil]]! !

!ControlManager methodsFor: 'accessing'!
screenController
    ^ screenController! !

!ControlManager methodsFor: 'accessing'!
windowOriginsInUse
    "Answer a collection of the origins of windows currently on the screen in the current project.  5/21/96 sw"

    ^ self scheduledWindowControllers collect: [:aController | aController view displayBox origin].! !


!ControlManager methodsFor: 'scheduling'!
activateController: aController
    "Make aController, which must already be a scheduled controller, the active window.  5/8/96 sw"

    self activeController: aController.
    (activeController view labelDisplayBox
        intersect: Display boundingBox) area < 200
            ifTrue: [activeController move].
    Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
activateTranscript
    "There is known to be a Transcript open in the current project; activate it.  2/5/96 sw"

    | itsController |
    itsController _ scheduledControllers detect:
            [:controller | controller model == Transcript]
        ifNone:
            [^ self].

    self activeController: itsController.
    (activeController view labelDisplayBox
            intersect: Display boundingBox) area < 200
                ifTrue: [activeController move].
    Processor terminateActive! !

!ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:26'!
cmdDotEnabled
    ^ CmdDotEnabled ~~ false! !

!ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:26'!
cmdDotEnabled: aBoolean
    CmdDotEnabled _ aBoolean! !

!ControlManager methodsFor: 'scheduling' stamp: 'di 5/19/1998 09:03'!
findWindow
    "Present a menu of window titles, and activate the one that gets chosen."

    ^ self findWindowSatisfying: [:c | true]! !

!ControlManager methodsFor: 'scheduling' stamp: 'sw 10/12/97 21:48'!
findWindowSatisfying: aBlock
    "Present a menu of window titles, and activate the one that gets chosen"

    | controllers labels index listToUse sortAlphabetically |
    sortAlphabetically _ Sensor optionKeyPressed.
    controllers _ OrderedCollection new.
    scheduledControllers do:
        [:controller | controller == screenController ifFalse:
            [(aBlock value: controller) ifTrue: [controllers addLast: controller]]].
    controllers size == 0 ifTrue: [^ self].
    listToUse _ sortAlphabetically
        ifTrue:
            [controllers asSortedCollection: [:a :b | a view label < b view label]]
        ifFalse:
            [controllers].
    labels _ String streamContents:
        [:strm |
            listToUse do: [:controller | strm nextPutAll: (controller view label contractTo: 40); cr].
        strm skip: -1  "drop last cr"].
    index _ (PopUpMenu labels: labels) startUp.
    index > 0 ifTrue:
        [self activateController: (controllers at: index)]! !

!ControlManager methodsFor: 'scheduling'!
inActiveControllerProcess
    "Answer whether the active scheduling process is the actual active
    process in the system."

    ^activeControllerProcess == Processor activeProcess! !

!ControlManager methodsFor: 'scheduling' stamp: 'tk 4/16/1998 15:38'!
interruptName: labelString
    "Create a Notifier on the active scheduling process with the given label. Make the Notifier the active controller."

    | suspendingList newActiveController |
    suspendingList _ activeControllerProcess suspendingList.
    suspendingList isNil ifTrue: [
        activeControllerProcess == Processor activeProcess
            ifTrue: [activeControllerProcess suspend].
    ] ifFalse: [
        suspendingList remove: activeControllerProcess.
        activeControllerProcess offList].

    activeController ~~ nil ifTrue: [
        "Carefully de-emphasis the current window."
        activeController view topView deEmphasizeForDebugger].

    newActiveController _
        (Debugger
            openInterrupt: labelString
            onProcess: activeControllerProcess) controller.
    newActiveController centerCursorInView.
    self activeController: newActiveController.
! !

!ControlManager methodsFor: 'scheduling' stamp: 'sw 9/30/97 13:27'!
maybeForkInterrupt

    self cmdDotEnabled ifTrue:
        [[self interruptName: 'User Interrupt'] fork]! !

!ControlManager methodsFor: 'scheduling'!
promote: aController
    "Make aController be the first scheduled controller in the ordered
    collection."

    scheduledControllers remove: aController.
    scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling'!
scheduleActive: aController
    "Make aController be scheduled as the active controller. Presumably the
    active scheduling process asked to schedule this controller and that a
    new process associated this controller takes control. So this is the last act
    of the active scheduling process."

    self scheduleActiveNoTerminate: aController.
    Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
scheduleActiveNoTerminate: aController
    "Make aController be the active controller. Presumably the process that
    requested the new active controller wants to keep control to do more
    activites before the new controller can take control. Therefore, do not
    terminate the currently active process."

    self schedulePassive: aController.
    self scheduled: aController
        from: Processor activeProcess! !

!ControlManager methodsFor: 'scheduling'!
scheduleOnBottom: aController
    "Make aController be scheduled as a scheduled controller, but not the
    active one. Put it at the end of the ordered collection of controllers."

    scheduledControllers addLast: aController! !

!ControlManager methodsFor: 'scheduling'!
schedulePassive: aController
    "Make aController be scheduled as a scheduled controller, but not the
    active one. Put it at the beginning of the ordered collection of
    controllers."

    scheduledControllers addFirst: aController! !

!ControlManager methodsFor: 'scheduling'!
searchForActiveController
    "Find a scheduled controller that wants control and give control to it. If
    none wants control, then see if the System Menu has been requested."
    | aController |
    activeController _ nil.
    activeControllerProcess _ Processor activeProcess.
    self activeController: self nextActiveController.
    Processor terminateActive! !

!ControlManager methodsFor: 'scheduling'!
unschedule: aController
    "Remove the view, aController, from the collection of scheduled
    controllers."

    scheduledControllers remove: aController ifAbsent: []! !

!ControlManager methodsFor: 'scheduling'!
windowFromUser
    "Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none"
    | controllers labels index |
    controllers _ OrderedCollection new.
    labels _ String streamContents:
        [:strm |
        scheduledControllers do:
            [:controller | controller == screenController ifFalse:
                [controllers addLast: controller.
                strm nextPutAll: (controller view label contractTo: 40); cr]].
        strm skip: -1  "drop last cr"].
    index _ (PopUpMenu labels: labels) startUp.
    ^ index > 0
        ifTrue:
            [controllers at: index]
        ifFalse:
            [nil]! !


!ControlManager methodsFor: 'displaying'!
backgroundForm: aForm
    screenController view model: aForm.
    ScheduledControllers restore
"
    QDPen new mandala: 30 diameter: 640.
    ScheduledControllers backgroundForm:
        (Form fromDisplay: Display boundingBox).

    ScheduledControllers backgroundForm:
        (InfiniteForm with: Form gray).
"! !

!ControlManager methodsFor: 'displaying' stamp: 'di 2/26/98 08:58'!
restore
    "Clear the screen to gray and then redisplay all the scheduled views.  Try to be a bit intelligent about the view that wants control and not display it twice if possible."

    scheduledControllers first view uncacheBits.  "assure refresh"
    self unschedule: screenController; scheduleOnBottom: screenController.
    screenController view window: Display boundingBox; displayDeEmphasized.
    self scheduledWindowControllers reverseDo:
        [:aController | aController view displayDeEmphasized].
! !

!ControlManager methodsFor: 'displaying'!
restore: aRectangle
    "Restore all windows visible in aRectangle"
    ^ self restore: aRectangle below: 1 without: nil! !

!ControlManager methodsFor: 'displaying'!
restore: aRectangle below: index without: aView
    "Restore all windows visible in aRectangle, but without aView"
    | view |
    view _ (scheduledControllers at: index) view.
    view == aView ifTrue:
        [index >= scheduledControllers size ifTrue: [^ self].
        ^ self restore: aRectangle below: index+1 without: aView].
    view displayOn: ((BitBlt toForm: Display) clipRect: aRectangle).
    index >= scheduledControllers size ifTrue: [^ self].
    (aRectangle areasOutside: view windowBox) do:
        [:rect | self restore: rect below: index + 1 without: aView]! !

!ControlManager methodsFor: 'displaying'!
restore: aRectangle without: aView
    "Restore all windows visible in aRectangle"
    ^ self restore: aRectangle below: 1 without: aView! !

!ControlManager methodsFor: 'displaying'!
updateGray
    "From Georg Gollmann - 11/96.  tell the Screen Controller's model to use the currently-preferred desktop color."

    "ScheduledControllers updateGray"
    (screenController view model isMemberOf: InfiniteForm)
        ifTrue: [screenController view model: (InfiniteForm with:
Preferences desktopColor)]! !


!ControlManager methodsFor: 'private'!
nextActiveController
    "Answer the controller that would like control.
    If there was a click outside the active window, it's the top window
    that now has the mouse, otherwise it's just the top window."

    (newTopClicked notNil and: [newTopClicked])
        ifTrue: [newTopClicked _ false.
                ^ scheduledControllers
                    detect: [:aController | aController isControlWanted]
                    ifNone: [scheduledControllers first]]
        ifFalse: [^ scheduledControllers first]! !

!ControlManager methodsFor: 'private'!
scheduled: aController from: aProcess

    activeControllerProcess==aProcess
        ifTrue:
            [activeController ~~ nil
                    ifTrue: [activeController controlTerminate].
            aController centerCursorInView.
            self activeController: aController]! !

!ControlManager methodsFor: 'private'!
unCacheWindows
    scheduledControllers do:
        [:aController | aController view uncacheBits]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ControlManager class
    instanceVariableNames: ''!

!ControlManager class methodsFor: 'instance creation' stamp: 'sw 9/30/97 13:25'!
initialize
    "ControlManager initialize"
    CmdDotEnabled _ true! !

!ControlManager class methodsFor: 'instance creation'!
new
    ^super new initialize! !


!ControlManager class methodsFor: 'exchange'!
newScheduler: controlManager
    "When switching projects, the control scheduler has to be exchanged. The
    active one is the one associated with the current project."

    Smalltalk at: #ScheduledControllers put: controlManager.
    ScheduledControllers restore.
    controlManager searchForActiveController! !


!ControlManager class methodsFor: 'snapshots' stamp: 'di 6/16/97 11:42'!
shutDown  "Saves space in snapshots"
    ScheduledControllers unCacheWindows! !

!ControlManager class methodsFor: 'snapshots'!
startUp
    ScheduledControllers restore! !
Object subclass: #Controller
    instanceVariableNames: 'model view sensor '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Framework'!
!Controller commentStamp: 'di 5/22/1998 16:33' prior: 0!
Controller comment:
'A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.'!


!Controller methodsFor: 'initialize-release'!
initialize
    "Initialize the state of the receiver. Subclasses should include 'super
    initialize' when redefining this message to insure proper initialization."

    sensor _ InputSensor default! !

!Controller methodsFor: 'initialize-release'!
release
    "Breaks the cycle between the receiver and its view. It is usually not
    necessary to send release provided the receiver's view has been properly
    released independently."

    model _ nil.
    view ~~ nil
        ifTrue:
            [view controller: nil.
            view _ nil]! !


!Controller methodsFor: 'model access'!
model
    "Answer the receiver's model which is the same as the model of the
    receiver's view."

    ^model! !

!Controller methodsFor: 'model access'!
model: aModel
    "Controller|model: and Controller|view: are sent by View|controller: in
    order to coordinate the links between the model, view, and controller. In
    ordinary usage, the receiver is created and passed as the parameter to
    View|controller: so that the receiver's model and view links can be set
    up by the view."

    model _ aModel! !


!Controller methodsFor: 'view access'!
inspectView
    view notNil ifTrue: [^ view inspect]! !

!Controller methodsFor: 'view access'!
view
    "Answer the receiver's view."

    ^view! !

!Controller methodsFor: 'view access'!
view: aView
    "Controller|view: and Controller|model: are sent by View|controller: in
    order to coordinate the links between the model, view, and controller. In
    ordinary usage, the receiver is created and passed as the parameter to
    View|controller: and the receiver's model and view links are set up
    automatically by the view."

    view _ aView! !


!Controller methodsFor: 'sensor access'!
sensor
    "Answer the receiver's sensor. Subclasses may use other objects that are
    not instances of Sensor or its subclasses if more general kinds of
    input/output functions are required."

    ^sensor! !

!Controller methodsFor: 'sensor access'!
sensor: aSensor
    "Set the receiver's sensor to aSensor."

    sensor _ aSensor! !


!Controller methodsFor: 'basic control sequence'!
controlInitialize
    "Sent by Controller|startUp as part of the standard control sequence, it
    provides a place in the standard control sequence for initializing the
    receiver (taking into account the current state of its model and view). It
    should be redefined in subclasses to perform some specific action."

    ^self! !

!Controller methodsFor: 'basic control sequence'!
controlLoop
    "Sent by Controller|startUp as part of the standard control sequence.
    Controller|controlLoop sends the message Controller|isControlActive to test
    for loop termination. As long as true is returned, the loop continues.
    When false is returned, the loop ends. Each time through the loop, the
    message Controller|controlActivity is sent."

    [self isControlActive] whileTrue: [self controlActivity. Processor yield]! !

!Controller methodsFor: 'basic control sequence'!
controlTerminate
    "Provide a place in the standard control sequence for terminating the
    receiver (taking into account the current state of its model and view). It
    should be redefined in subclasses to perform some specific action."

    ^self! !

!Controller methodsFor: 'basic control sequence'!
startUp
    "Give control to the receiver. The default control sequence is to initialize
    (see Controller|controlInitialize), to loop (see Controller|controlLoop), and
    then to terminate (see Controller|controlTerminate). After this sequence,
    control is returned to the sender of Control|startUp. The receiver's control
    sequence is used to coordinate the interaction of its view and model. In
    general, this consists of polling the sensor for user input, testing the
    input with respect to the current display of the view, and updating the
    model to reflect intended changes."

    self controlInitialize.
    self controlLoop.
    self controlTerminate! !

!Controller methodsFor: 'basic control sequence'!
terminateAndInitializeAround: aBlock
    "1/12/96 sw"
    self controlTerminate.
    aBlock value.
    self controlInitialize! !


!Controller methodsFor: 'control defaults'!
controlActivity
    "Pass control to the next control level (that is, to the Controller of a
    subView of the receiver's view) if possible. It is sent by
    Controller|controlLoop each time through the main control loop. It should
    be redefined in a subclass if some other action is needed."

    self controlToNextLevel! !

!Controller methodsFor: 'control defaults'!
controlToNextLevel
    "Pass control to the next control level (that is, to the Controller of a
    subView of the receiver's view) if possible. The receiver finds the
    subView (if any) of its view whose inset display box (see
    View|insetDisplayBox) contains the sensor's cursor point. The Controller
    of this subView is then given control if it answers true in response to
    the message Controller|isControlWanted."

    | aView |
    aView _ view subViewWantingControl.
    aView ~~ nil ifTrue: [aView controller startUp]! !

!Controller methodsFor: 'control defaults'!
isControlActive
    "Answer whether receiver wishes to continue evaluating its controlLoop
    method. It is sent by Controller|controlLoop in order to determine when
    the receiver's control loop should terminate, and should be redefined in
    a subclass if some special condition for terminating the main control loop
    is needed."

    ^ self viewHasCursor
        & sensor blueButtonPressed not
        & sensor yellowButtonPressed not
        "& sensor cmdKeyPressed not"! !

!Controller methodsFor: 'control defaults'!
isControlWanted
    "Answer whether the cursor is inside the inset display box (see
    View|insetDisplayBox) of the receiver's view. It is sent by
    Controller|controlNextLevel in order to determine whether or not control
    should be passed to this receiver from the Controller of the superView of
    this receiver's view."

    ^self viewHasCursor! !


!Controller methodsFor: 'cursor'!
centerCursorInView
    "Position sensor's mousePoint (which is assumed to be connected to the
    cursor) to the center of its view's inset display box (see
    Sensor|mousePoint: and View|insetDisplayBox)."

    ^sensor cursorPoint: view insetDisplayBox center! !

!Controller methodsFor: 'cursor'!
viewHasCursor
    "Answer whether the cursor point of the receiver's sensor lies within the
    inset display box of the receiver's view (see View|insetDisplayBox).
    Controller|viewHasCursor is normally used in internal methods."

    ^view containsPoint: sensor cursorPoint! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Controller class
    instanceVariableNames: ''!

!Controller class methodsFor: 'instance creation'!
new

    ^super new initialize! !
Form subclass: #Cursor
    instanceVariableNames: ''
    classVariableNames: 'BlankCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor ReadCursor RightArrowCursor SquareCursor UpCursor WaitCursor WriteCursor XeqCursor '
    poolDictionaries: ''
    category: 'Graphics-Display Objects'!
!Cursor commentStamp: 'di 5/22/1998 16:33' prior: 0!
Cursor comment:
'I am a 16 x 16 dot matrix suitable for use as the Alto hardware cursor.'!


!Cursor methodsFor: 'updating'!
changed: aParameter

    self == CurrentCursor ifTrue: [self beCursor].
    super changed: aParameter! !


!Cursor methodsFor: 'displaying'!
beCursor
    "Primitive. Tell the interpreter to use the receiver as the current cursor
    image. Fail if the receiver does not match the size expected by the
    hardware. Essential. See Object documentation whatIsAPrimitive."

    <primitive: 101>
    self primitiveFailed! !

!Cursor methodsFor: 'displaying'!
show
    "Make the current cursor shape be the receiver."

    Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying'!
showGridded: gridPoint
    "Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint."

    Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint).
    Sensor currentCursor: self! !

!Cursor methodsFor: 'displaying'!
showWhile: aBlock
    "While evaluating the argument, aBlock, make the receiver be the cursor
    shape."

    | oldcursor value |
    oldcursor _ Sensor currentCursor.
    self show.
    value _ aBlock value.
    oldcursor show.
    ^value! !


!Cursor methodsFor: 'printing'!
printOn: aStream

    self storeOn: aStream base: 2! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Cursor class
    instanceVariableNames: ''!

!Cursor class methodsFor: 'class initialization'!
initCorner

    CornerCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r1111111111111111
        2r1111111111111111)
            offset: -16@-16).
! !

!Cursor class methodsFor: 'class initialization'!
initCrossHair

    CrossHairCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r1111111111111110
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0000000100000000
        2r0)
            offset: -7@-7).

    ! !

!Cursor class methodsFor: 'class initialization'!
initDown

    DownCursor  _
             (Cursor
    extent: 16@16
    fromArray: #(
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r1111110000000000
        2r111100000000000
        2r11000000000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initialize
    "Create all the standard cursors
        Cursor origin
        Cursor rightArrow
        Cursor menu
        Cursor corner
        Cursor read
        Cursor write
        Cursor wait
        Cursor blank
        Cursor xeq
        Cursor square
        Cursor normal
        Cursor crossHair
        Cursor marker
        Cursor up
        Cursor down
        Cursor move"

        self initOrigin.
        self initRightArrow.
        self initMenu.
        self initCorner.
        self initRead.
        self initWrite.
        self initWait.
        BlankCursor _ Cursor new.
        self initXeq.
        self initSquare.
        self initNormal.
        self initCrossHair.
        self initMarker.
        self initUp.
        self initDown.
        self initMove.

        "Cursor initialize"
! !

!Cursor class methodsFor: 'class initialization'!
initMarker

    MarkerCursor _
        Cursor
            extent: 16@16
            fromArray: #(
        2r0111000000000000
        2r1111100000000000
        2r1111100000000000
        2r0111000000000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
            offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization'!
initMenu

    MenuCursor  _
                (Cursor
    extent: 16@16
    fromArray: #(
        2r1111111111100000
        2r1000000000100000
        2r1010011000100000
        2r1000000000100000
        2r1011001010100000
        2r1000000000100000
        2r1010110010100000
        2r1000000000100000
        2r1010010100100000
        2r1000000000100000
        2r1111111111100000
        2r1101001101100000
        2r1111111111100000
        2r1000000000100000
        2r1010101100100000
        2r1111111111100000)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initMove

    MoveCursor _
        Cursor
            extent: 16@16
            fromArray: #(
        2r1111111111111111
        2r1111111111111111
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1111111111111111
        2r1111111111111111
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1100000110000011
        2r1111111111111111
        2r1111111111111111)
            offset: 0@0.
! !

!Cursor class methodsFor: 'class initialization'!
initNormal

    NormalCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r1000000000000000
        2r1100000000000000
        2r1110000000000000
        2r1111000000000000
        2r1111100000000000
        2r1111110000000000
        2r1111111000000000
        2r1111100000000000
        2r1111100000000000
        2r1001100000000000
        2r0000110000000000
        2r0000110000000000
        2r0000011000000000
        2r0000011000000000
        2r0000001100000000
        2r0000001100000000)
    offset: 0@0).


    ! !

!Cursor class methodsFor: 'class initialization'!
initOrigin

    OriginCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r1111111111111111
        2r1111111111111111
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000)
            offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initRead

    ReadCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r0000110000000110
        2r0001001000001001
        2r0001001000001001
        2r0010000000010000
        2r0100000000100000
        2r1111101111100000
        2r1000010000100000
        2r1000010000100000
        2r1011010110100000
        2r0111101111000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initRightArrow

    RightArrowCursor  _
              (Cursor
    extent: 16@16
    fromArray: #(
        2r100000000000
        2r111000000000
        2r1111111110000000
        2r111000000000
        2r100000000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
    offset: 0@0).

    "Cursor initRightArrow"! !

!Cursor class methodsFor: 'class initialization'!
initSquare

    SquareCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0000001111000000
        2r0000001111000000
        2r0000001111000000
        2r0000001111000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
    offset: -8@-8).

    ! !

!Cursor class methodsFor: 'class initialization'!
initUp

    UpCursor _
            (Cursor
    extent: 16@16
    fromArray: #(
        2r11000000000000
        2r111100000000000
        2r1111110000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r11000000000000
        2r0
        2r0
        2r0
        2r0
        2r0
        2r0)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initWait

    WaitCursor _
          (Cursor
            extent: 16@16
            fromArray: #(
        2r1111111111111111
        2r1000000000000001
        2r0100000000000010
        2r0010000000000100
        2r0001110000111000
        2r0000111101110000
        2r0000011011100000
        2r0000001111000000
        2r0000001111000000
        2r0000010110100000
        2r0000100010010000
        2r0001000110001000
        2r0010001101000100
        2r0100111111110010
        2r1011111111111101
        2r1111111111111111)
            offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initWrite

    WriteCursor _ (Cursor
    extent: 16@16
    fromArray: #(
        2r0000000000000110
        2r0000000000001111
        2r0000000000010110
        2r0000000000100100
        2r0000000001001000
        2r0000000010010000
        2r0000000100100000
        2r0000001001000011
        2r0000010010000010
        2r0000100100000110
        2r0001001000001000
        2r0010010000001000
        2r0111100001001000
        2r0101000010111000
        2r0110000110000000
        2r1111111100000000)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
initXeq

    XeqCursor _
        (Cursor
            extent: 16@16
            fromArray: #(
        2r1000000000010000
        2r1100000000010000
        2r1110000000111000
        2r1111000111111111
        2r1111100011000110
        2r1111110001000100
        2r1111111001111100
        2r1111000001101100
        2r1101100011000110
        2r1001100010000010
        2r0000110000000000
        2r0000110000000000
        2r0000011000000000
        2r0000011000000000
        2r0000001100000000
        2r0000001100000000)
    offset: 0@0).
! !

!Cursor class methodsFor: 'class initialization'!
startUp
    self currentCursor: self currentCursor! !


!Cursor class methodsFor: 'instance creation'!
extent: extentPoint fromArray: anArray offset: offsetPoint
    "Answer a new instance of me with width and height specified by
    extentPoint, offset by offsetPoint, and bits from anArray.
    NOTE: This has been kluged to take an array of 16-bit constants,
    and shift them over so they are left-justified in a 32-bit bitmap"

    extentPoint = (16 @ 16)
        ifTrue:
            [^ super
                extent: extentPoint
                fromArray: (anArray collect: [:bits | bits bitShift: 16])
                offset: offsetPoint]
        ifFalse: [self error: 'cursors must be 16@16']! !

!Cursor class methodsFor: 'instance creation'!
new

    ^self
        extent: 16 @ 16
        fromArray: Array new
        offset: 0 @ 0

    "Cursor new bitEdit show"! !


!Cursor class methodsFor: 'current cursor'!
currentCursor
    "Answer the instance of Cursor that is the one currently displayed."

    ^CurrentCursor! !

!Cursor class methodsFor: 'current cursor'!
currentCursor: aCursor
    "Make the instance of cursor, aCursor, be the current cursor. Display it.
    Create an error if the argument is not a Cursor."

    aCursor class == self
        ifTrue:
            [CurrentCursor _ aCursor.
            aCursor beCursor]
        ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! !


!Cursor class methodsFor: 'constants'!
blank
    "Answer the instance of me that is all white."

    ^BlankCursor! !

!Cursor class methodsFor: 'constants'!
bottomLeft
    "Cursor bottomLeft showWhile: [Sensor waitButton]"
    ^ (Cursor extent: 16@16
            fromArray: #(
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1111111111111111
        2r1111111111111111)
            offset: 0@-16).
! !

!Cursor class methodsFor: 'constants'!
bottomRight
    "Cursor bottomRight showWhile: [Sensor waitButton]"
    ^ (Cursor extent: 16@16
            fromArray: #(
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r1111111111111111
        2r1111111111111111)
            offset: -16@-16).
! !

!Cursor class methodsFor: 'constants'!
corner
    "Answer the instance of me that is the shape of the bottom right corner
    of a rectangle."

    ^CornerCursor! !

!Cursor class methodsFor: 'constants'!
crossHair
    "Answer the instance of me that is the shape of a cross."

    ^CrossHairCursor! !

!Cursor class methodsFor: 'constants'!
down
    "Answer the instance of me that is the shape of an arrow facing
    downward."

    ^DownCursor! !

!Cursor class methodsFor: 'constants'!
execute
    "Answer the instance of me that is the shape of an arrow slanted left
    with a star next to it."

    ^XeqCursor! !

!Cursor class methodsFor: 'constants'!
marker
    "Answer the instance of me that is the shape of a small ball."

    ^MarkerCursor! !

!Cursor class methodsFor: 'constants'!
menu
    "Answer the instance of me that is the shape of a menu."

    ^MenuCursor! !

!Cursor class methodsFor: 'constants'!
move
    "Answer the instance of me that is the shape of a cross inside a square."

    ^MoveCursor! !

!Cursor class methodsFor: 'constants'!
normal
    "Answer the instance of me that is the shape of an arrow slanted left."

    ^NormalCursor! !

!Cursor class methodsFor: 'constants'!
origin
    "Answer the instance of me that is the shape of the top left corner of a
    rectangle."

    ^OriginCursor! !

!Cursor class methodsFor: 'constants'!
read
    "Answer the instance of me that is the shape of eyeglasses."

    ^ReadCursor! !

!Cursor class methodsFor: 'constants'!
rightArrow
    "Answer the instance of me that is the shape of an arrow pointing to the right."

    ^RightArrowCursor! !

!Cursor class methodsFor: 'constants'!
square
    "Answer the instance of me that is the shape of a square."

    ^SquareCursor! !

!Cursor class methodsFor: 'constants'!
topLeft
    "Cursor topLeft showWhile: [Sensor waitButton]"
    ^ (Cursor extent: 16@16
            fromArray: #(
        2r1111111111111111
        2r1111111111111111
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000
        2r1100000000000000)
            offset: 0@0).
! !

!Cursor class methodsFor: 'constants'!
topRight
    "Cursor topRight showWhile: [Sensor waitButton]"
    ^ (Cursor extent: 16@16
            fromArray: #(
        2r1111111111111111
        2r1111111111111111
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011
        2r0000000000000011)
            offset: -16@0).
! !

!Cursor class methodsFor: 'constants'!
up
    "Answer the instance of me that is the shape of an arrow facing upward."

    ^UpCursor! !

!Cursor class methodsFor: 'constants' stamp: 'sw 8/15/97 13:28'!
wait
    "Answer the instance of me that is the shape of an Hourglass (was in the
    shape of three small balls)."

    ^WaitCursor! !

!Cursor class methodsFor: 'constants'!
write
    "Answer the instance of me that is the shape of a pen writing."

    ^WriteCursor! !
Path subclass: #CurveFitter
    instanceVariableNames: ''
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Graphics-Paths'!
!CurveFitter commentStamp: 'di 5/22/1998 16:33' prior: 0!
CurveFitter class comment:
'I represent a conic section determined by three points p1,p2 and p3. I interpolate p1 and p3 and am tangent to line p1,p2 at p1 and line p3,p2 at p3.'!


!CurveFitter methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

    | pa pb k s p1 p2 p3 line |
    line _ Line new.
    line form: self form.
    collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points'].
    p1 _ self firstPoint.
    p2 _ self secondPoint.
    p3 _ self thirdPoint.
    s _ Path new.
    s add: p1.
    pa _ p2 - p1.
    pb _ p3 - p2.
    k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20.
    "k is a guess as to how many line segments to use to approximate
    the curve."
    1 to: k do:
        [:i |
        s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)].
    s add: p3.
    1 to: s size - 1 do:
        [:i |
        line beginPoint: (s at: i).
        line endPoint: (s at: i + 1).
        line displayOn: aDisplayMedium
            at: aPoint
            clippingBox: clipRect
            rule: anInteger
            fillColor: aForm]! !

!CurveFitter methodsFor: 'displaying' stamp: '6/9/97 10:16 di'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

    | transformedPath newCurveFitter |
    transformedPath _ aTransformation applyTo: self.
    newCurveFitter _ CurveFitter new.
    newCurveFitter firstPoint: transformedPath firstPoint.
    newCurveFitter secondPoint: transformedPath secondPoint.
    newCurveFitter thirdPoint: transformedPath thirdPoint.
    newCurveFitter form: self form.
    newCurveFitter
        displayOn: aDisplayMedium
        at: 0 @ 0
        clippingBox: clipRect
        rule: anInteger
        fillColor: aForm! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CurveFitter class
    instanceVariableNames: ''!

!CurveFitter class methodsFor: 'instance creation'!
new

    | newSelf |
    newSelf _ super new: 3.
    newSelf add: 0@0.
    newSelf add: 0@0.
    newSelf add: 0@0.
    ^newSelf! !


!CurveFitter class methodsFor: 'examples' stamp: '6/9/97 10:16 di'!
example
    "Designate three locations on the screen by clicking any button. The
    curve determined by the points will be displayed with a long black form."

    | aCurveFitter aForm |
    aForm _ Form extent: 1@30.            "make a long thin Form for display "
    aForm fillBlack.                            "turn it black"
    aCurveFitter _ CurveFitter new.
    aCurveFitter form: aForm.                        "set the form for display"
                "collect three Points and show them on the dispaly"
    aCurveFitter firstPoint: Sensor waitButton. Sensor waitNoButton.
    aForm displayOn: Display at: aCurveFitter firstPoint.
    aCurveFitter secondPoint: Sensor waitButton. Sensor waitNoButton.
    aForm displayOn: Display at: aCurveFitter secondPoint.
    aCurveFitter thirdPoint: Sensor waitButton. Sensor waitNoButton.
    aForm displayOn: Display at: aCurveFitter thirdPoint.

    aCurveFitter displayOn: Display                    "display the CurveFitter"

    "CurveFitter example"! !
PolygonMorph subclass: #CurveMorph
    instanceVariableNames: 'coefficients ntfPoint ntlPoint '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Basic'!

!CurveMorph methodsFor: 'private' stamp: 'di 9/26/97 10:31'!
addHandles
    super addHandles.
    self updateHandles! !

!CurveMorph methodsFor: 'private' stamp: '6/9/97 21:28 di'!
computeCurve
    "Compute an array for the coefficients.  This is copied from Flegal's old
    code in the Spline class."
    | length extras verts |
    verts _ closed ifTrue: [vertices copyWith: vertices first]
                ifFalse: [vertices].
    length _ verts size.
    extras _ 0.
    coefficients _ Array new: 8.
    1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)].
    1 to: 5 by: 4 do:
        [:k |
        1 to: length do:
            [:i | (coefficients at: k)
                    at: i put: (k = 1
                        ifTrue: [(verts at: i) x asFloat]
                        ifFalse: [(verts at: i) y asFloat])].
            1 to: extras do: [:i | (coefficients at: k)
                    at: length + i put: ((coefficients at: k)
                        at: i + 1)].
            self derivs: (coefficients at: k)
                first: (coefficients at: k + 1)
                second: (coefficients at: k + 2)
                third: (coefficients at: k + 3)].
    extras > 0
        ifTrue: [1 to: 8 do:
                    [:i |
                    coefficients at: i put: ((coefficients at: i)
                                            copyFrom: 2 to: length + 1)]]! !

!CurveMorph methodsFor: 'private' stamp: 'di 12/3/97 11:00'!
curveBounds
    "Compute the bounds from actual curve traversal, with leeway for borderWidth.
    Also note the next-to-first and next-to-last points for arrow directions."
    | curveBounds |
    self computeCurve.
    curveBounds _ vertices first corner: vertices last.
    ntfPoint _ nil.
    self lineSegmentsDo:
        [:p1 :p2 | ntfPoint == nil ifTrue: [ntfPoint _ p2 asIntegerPoint].
        curveBounds _ curveBounds encompass: p2 asIntegerPoint.
        ntlPoint _ p1 asIntegerPoint].
    ^ curveBounds expandBy: borderWidth+1//2! !

!CurveMorph methodsFor: 'private' stamp: '6/9/97 10:32 di'!
derivs: a first: point1 second: point2 third: point3
    "Compute the first, second and third derivitives (in coefficients) from
    the Points in this Path (coefficients at: 1 and coefficients at: 5)."
    | len v anArray |
    len _ a size.
    len < 2 ifTrue: [^self].
    len > 2 ifTrue:
        [v _ Array new: len.
         v  at: 1 put: 4.0.
         anArray _ Array new: len.
         anArray at: 1 put: (6.0 * ((a at: 1) - ((a at: 2) * 2.0) + (a at: 3))).
         2 to: len - 2 do:
            [:i |
            v  at: i put: (4.0 - (1.0 / (v at: i-1))).
            anArray at: i
                put: (6.0 * ((a at: i) - ((a at: i+1) * 2.0) + (a at: i+2))
                        - ((anArray at: i-1) / (v at: i-1)))].
         point2 at: len-1 put: ((anArray at: len-2) / (v at: len-2)).
         len - 2 to: 2 by: 0-1 do:
            [:i |
            point2 at: i
                put: ((anArray at: i-1) - (point2 at: i+1) / (v at: i-1))]].
    point2 at: 1 put: (point2 at: len put: 0.0).
    1 to: len - 1 do:
        [:i | point1 at: i
                put: ((a at: i+1) - (a at: i) -
                        ((point2 at: i) * 2.0 + (point2 at: i+1) / 6.0)).
              point3 at: i put: ((point2 at: i+1) - (point2 at: i))]! !

!CurveMorph methodsFor: 'private' stamp: 'di 12/4/97 09:45'!
isCurve
    ^ true! !

!CurveMorph methodsFor: 'private' stamp: 'di 11/29/97 20:54'!
lineSegmentsDo: endPointsBlock
    "Emit a sequence of line segments into endPointsBlock to approximate this spline."
    | n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint |
    vertices size < 1 ifTrue: [^ self].
    beginPoint _ (x _ (coefficients at: 1) at: 1) @ (y _ (coefficients at: 5) at: 1).
    1 to: (coefficients at: 1) size - 1 do:
        [:i |  "taylor series coefficients"
        x1 _ (coefficients at: 2) at: i.
        y1 _ (coefficients at: 6) at: i.
        x2 _ ((coefficients at: 3) at: i) / 2.0.
        y2 _ ((coefficients at: 7) at: i) / 2.0.
        x3 _ ((coefficients at: 4) at: i) / 6.0.
        y3 _ ((coefficients at: 8) at: i) / 6.0.
        "guess n"
        n _ 5 max: (x2 abs + y2 abs * 2.0 + ((coefficients at: 3) at: i+1) abs
                                    + ((coefficients at: 7) at: i+1) abs / 100.0) rounded.
        1 to: n - 1 do:
            [:j |
            t _ j asFloat / n.
            endPoint _ (x3 * t + x2 * t + x1 * t + x) @ (y3 * t + y2 * t + y1 * t + y).
            endPointsBlock value: beginPoint
                            value: endPoint.
            beginPoint _ endPoint].
        endPoint _ (x _ (coefficients at: 1) at: i+1) @ (y _ (coefficients at: 5) at: i+1).
        endPointsBlock value: beginPoint
                        value: endPoint.
        beginPoint _ endPoint]! !

!CurveMorph methodsFor: 'private' stamp: '6/9/97 12:08 di'!
nextToFirstPoint  "For arrow direction"
    ^ ntfPoint! !

!CurveMorph methodsFor: 'private' stamp: '6/9/97 12:08 di'!
nextToLastPoint  "For arrow direction"
    ^ ntlPoint! !

!CurveMorph methodsFor: 'private' stamp: '6/9/97 13:57 di'!
privateMoveBy: delta
    super privateMoveBy: delta.
    self computeCurve! !

!CurveMorph methodsFor: 'private' stamp: 'di 1/26/98 23:54'!
updateHandles
    | midPts nextVertIx tweens newVert p2i |
    midPts _ OrderedCollection new.
    nextVertIx _ 2.
    tweens _ OrderedCollection new.
    self lineSegmentsDo:
        [:p1 :p2 | p2i _ p2 asIntegerPoint.
        tweens addLast: p2i.
        p2i = (vertices atWrap: nextVertIx) ifTrue:
            ["Found endPoint."
            midPts addLast: (tweens at: tweens size // 2)
                        + (tweens at: tweens size + 1 // 2) // 2.
            tweens _ OrderedCollection new.
            nextVertIx _ nextVertIx + 1]].
    midPts withIndexDo:
        [:midPt :vertIndex |
        (closed or: [vertIndex < vertices size]) ifTrue:
            [newVert _ handles at: vertIndex*2.
            newVert position: midPt - (newVert extent // 2)]].! !
SelectionMenu subclass: #CustomMenu
    instanceVariableNames: 'labels dividers lastDivider '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Interface-Menus'!
!CustomMenu commentStamp: 'di 5/22/1998 16:33' prior: 0!
CustomMenu comment:
'I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:

    add: aString action: anAction
    addLine

After the menu is constructed, it may be invoked with one of the following messages:

    invoke: initialSelection
    invoke

I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:

    items _ an OrderedCollection of strings to appear in the menu
    selectors _ an OrderedCollection of Symbols to be used as message selectors
    lineArray _ an OrderedCollection of line positions
    lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray'!


!CustomMenu methodsFor: 'initialize-release'!
initialize

    labels _ OrderedCollection new.
    selections _ OrderedCollection new.
    dividers _ OrderedCollection new.
    lastDivider _ 0.! !


!CustomMenu methodsFor: 'construction'!
add: aString action: actionItem
    "Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."

    | s |
    s _ String new: aString size + 2.
    s at: 1 put: Character space.
    s replaceFrom: 2 to: s size - 1 with: aString.
    s at: s size put: Character space.
    labels addLast: s.
    selections addLast: actionItem.! !

!CustomMenu methodsFor: 'construction'!
addLine
    "Append a line to the menu after the last entry. Suppress duplicate lines."

    (lastDivider ~= selections size) ifTrue: [
        lastDivider _ selections size.
        dividers addLast: lastDivider].! !

!CustomMenu methodsFor: 'construction' stamp: 'jm 3/29/98 07:09'!
addList: listOfPairs
    "Add a menu item to the receiver for each pair in the given list of the form (<what to show> <selector>). Add a line for each dash (-) in the list."
    "CustomMenu new addList: #(
        ('apples' buyApples)
        ('oranges' buyOranges)
        -
        ('milk' buyMilk)); startUp"

    listOfPairs do: [:pair |
        #- = pair
            ifTrue: [self addLine]
            ifFalse: [self add: pair first action: pair last]].
! !

!CustomMenu methodsFor: 'construction' stamp: 'jm 5/6/1998 19:47'!
labels: aString lines: linesArray selections: selectionsArray
    "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."

    | labelList |
    labelList _ (aString findTokens: String cr) asArray.
    1 to: labelList size do: [:i |
        self add: (labelList at: i) action: (selectionsArray at: i).
        (linesArray includes: i) ifTrue: [self addLine]].
! !


!CustomMenu methodsFor: 'invocation' stamp: 'jm 11/17/97 16:54'!
invokeOn: targetObject defaultSelection: defaultSelection
    "Invoke the menu with the given default selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."

    | sel |
    sel _ self startUp: defaultSelection.
    sel = nil ifFalse: [
        sel numArgs = 0
            ifTrue: [^ targetObject perform: sel]
            ifFalse: [^ targetObject perform: sel with: nil]].
    ^ nil
! !

!CustomMenu methodsFor: 'invocation'!
startUp
    "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

    ^ self startUp: nil! !

!CustomMenu methodsFor: 'invocation'!
startUp: initialSelection
    "Build and invoke this menu with the given initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

    ^ self startUp: initialSelection withCaption: nil! !

!CustomMenu methodsFor: 'invocation'!
startUp: initialSelection withCaption: caption
    "Build and invoke this menu with the given initial selection and caption. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

    self build.
    (initialSelection notNil) ifTrue: [self preSelect: initialSelection].
    ^ super startUpWithCaption: caption! !

!CustomMenu methodsFor: 'invocation' stamp: 'sw 7/31/97 19:31'!
startUpWithCaption: caption
    "Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption"

    ^ self startUp: nil withCaption: caption! !


!CustomMenu methodsFor: 'private'!
build
    "Turn myself into an invokable ActionMenu."

    | stream |
    stream _ WriteStream on: (String new).
    labels do: [: label | stream nextPutAll: label; cr].
    (labels isEmpty) ifFalse: [stream skip: -1].  "remove final cr"
    self labels: stream contents
        font: (TextStyle default fontAt: 1)
        lines: dividers.! !

!CustomMenu methodsFor: 'private'!
preSelect: action
    "Pre-select and highlight the menu item associated with the given action."

    | i |
    i _ selections indexOf: action ifAbsent: [^ self].
    marker _ marker
        align: marker topLeft
        with: (marker left)@(frame inside top + (marker height * (i - 1))).
    selection _ i.! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CustomMenu class
    instanceVariableNames: ''!

!CustomMenu class methodsFor: 'instance creation'!
new

    ^ super new initialize! !


!CustomMenu class methodsFor: 'example'!
example
    "CustomMenu example"

    | menu |
    menu _ CustomMenu new.
    menu add: 'apples' action: #apples.
    menu add: 'oranges' action: #oranges.
    menu addLine.
    menu addLine.  "extra lines ignored"
    menu add: 'peaches' action: #peaches.
    menu addLine.
    menu add: 'pears' action: #pears.
    menu addLine.
    ^ menu startUp: #apples! !
Object subclass: #DamageRecorder
    instanceVariableNames: 'invalidRects totalRepaint '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Morphic-Support'!

!DamageRecorder methodsFor: 'all'!
doFullRepaint
    "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset."

    ^ totalRepaint _ true.
! !

!DamageRecorder methodsFor: 'all'!
invalidRectsFullBounds: aRectangle
    "Return a collection of damaged rectangles for the given canvas. If a total repaint has been requested, return the given rectangle."

    totalRepaint
        ifTrue: [^ Array with: aRectangle]
        ifFalse: [^ invalidRects copy].

! !

!DamageRecorder methodsFor: 'all' stamp: 'jm 5/22/1998 14:07'!
recordInvalidRect: aRectangle
    "Record the given rectangle in my damage list, a list of rectagular areas of the display that should be redraw on the next display cycle."
    "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle."

    | mergeRect |
    totalRepaint ifTrue: [^ self].  "planning full repaint; don't bother collecting damage"

    invalidRects do: [:rect |
        (rect intersects: aRectangle) ifTrue: [
            "merge rectangle in place (see note below) if there is any overlap"
            rect setOrigin: (rect origin min: aRectangle origin) truncated
                corner: (rect corner max: aRectangle corner) truncated.
            ^ self]].


    invalidRects size >= 10 ifTrue: [
        "if there are too many separate areas, just repaint all"
        "totalRepaint _ true."
"Note:  The totalRepaint policy has poor behavior when many local rectangles (such as parts of a text selection) force repaint of the entire screen.  As an alternative, this code performs a simple merge of all rects whenever there are more than 10."
        mergeRect _ Rectangle merging: invalidRects.
        self reset.
        invalidRects addLast: mergeRect].

    "add the given rectangle to the damage list"
    "Note: We make a deep copy of all rectangles added to the damage list,
     since rectangles in this list may be extended in place."
    invalidRects addLast: (aRectangle topLeft truncated corner: aRectangle bottomRight truncated).
! !

!DamageRecorder methodsFor: 'all'!
reset
    "Clear the damage list."

    invalidRects _ OrderedCollection new.
    totalRepaint _ false.
! !

!DamageRecorder methodsFor: 'all'!
updateIsNeeded
    "Return true if the display needs to be updated."

    ^ totalRepaint or: [invalidRects size > 0]
! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DamageRecorder class
    instanceVariableNames: ''!

!DamageRecorder class methodsFor: 'instance creation'!
new

    ^ super new reset
! !
UpdatingStringMorph subclass: #DataMorph
    instanceVariableNames: 'dataType status '
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Experimental-Miscellaneous'!
!DataMorph commentStamp: 'di 5/22/1998 16:33' prior: 0!
A morph representing data to be borne by a slot encompassing pasteUpMorph, as a step toward a stack/card architecture.  This is work in progress, and should be approached with the mose extreme caution.!


!DataMorph methodsFor: 'all' stamp: 'sw 5/2/1998 16:55'!
becomeField
    | aStack slotNameChosen  |
    aStack _ self pasteUpMorph assuredCostumee.

    slotNameChosen _ aStack addSlotNamedLike: self externalName withValue: self valueFromContents.

    self getSelector: (Utilities getterSelectorFor: slotNameChosen).
    self putSelector: (Utilities setterSelectorFor: slotNameChosen).
    self target: aStack.
    status _ #field.
    aStack updateAllViewers! !

!DataMorph methodsFor: 'all' stamp: 'sw 5/8/1998 13:41'!
dockUpToInstance: anInstance
    "The enclosing PasteUpMorph's current instance has changed (i.e., a new card is been 'gone to'), so do what is necessary"
    | oldTarget |
    self flag: #deferred.  "Not ready for use"
    oldTarget _ target.
    target _ anInstance.
    self  readFromTarget.
    contents == nil ifTrue: [contents _ '<new>'].
    getSelector == nil ifTrue: [self isThisEverCalled].
    oldTarget == target ifFalse: [oldTarget updateAllViewers]! !

!DataMorph methodsFor: 'all' stamp: 'sw 5/2/1998 17:18'!
drawOn: aCanvas
    | borderColorToUse |
    borderColorToUse _ status == #field
        ifTrue:
            [Color blue muchLighter]
        ifFalse:
            [Color red lighter].
    aCanvas frameAndFillRectangle: bounds
        fillColor: Color blue veryMuchLighter
        borderWidth: 1
        borderColor: borderColorToUse.

    super drawOn: aCanvas.! !

!DataMorph methodsFor: 'all' stamp: 'sw 4/27/1998 19:04'!
holdsDataForEachInstance
    ^ status == #field! !

!DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:32'!
initializeAsAuthoringPrototypeOfType: typeSymbol
    dataType _ typeSymbol.
     typeSymbol == #string
        ifTrue:
            [self useStringFormat]
        ifFalse:
            [self useDefaultFormat].
    status _ #field.
    lastValue _ contents _ 'Data'.
    self setNameTo: 'field'! !

!DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:41'!
setLiteral: anObject
    "Like much else here, not yet in service"
    dataType _ #literal.
    lastValue _ anObject.
    contents _ anObject
! !

!DataMorph methodsFor: 'all' stamp: 'sw 4/27/1998 16:58'!
wantsKeyboardFocusFor: aSubmorph
    ^ self inPartsBin not! !

!DataMorph methodsFor: 'all' stamp: 'sw 5/6/1998 16:33'!
wouldAcceptKeyboardFocus
    ^ self inPartsBin not! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DataMorph class
    instanceVariableNames: ''!

!DataMorph class methodsFor: 'as yet unclassified' stamp: 'sw 4/27/1998 16:32'!
authoringPrototype
    ^ self new initializeAsAuthoringPrototypeOfType: #string! !
Stream subclass: #DataStream
    instanceVariableNames: 'byteStream topCall basePos '
    classVariableNames: 'TypeMap '
    poolDictionaries: ''
    category: 'System-Object Storage'!
!DataStream commentStamp: 'di 5/22/1998 16:33' prior: 0!
DataStream comment:
'This is the save-to-disk facility. A DataStream can store one or more objects in a persistent form.

To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream.  (Or SmartRefStream.)  ReferenceStream is typically
faster and produces smaller files because it doesn''t repeatedly write the same Symbols.

Here is the way to use DataStream and ReferenceStream:
    rr _ ReferenceStream fileNamed: ''test.obj''.
    rr nextPut: <your object>.
    rr close.

To get it back:
    rr _ ReferenceStream fileNamed: ''test.obj''.
    <your object> _ rr next.
    rr close.

Each object to be stored has two opportunities to control what gets stored. The high level, more useful hook is objectToStoreOnDataStream [externalize]. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload [internalize] and (class) readDataFrom:size:. See these methods, the class DiskProxy, and the class IOWeakArray for more information about externalizing and internalizing.

Public messages:
    (class) on:
    (class) fileNamed:
    (class) fileTypeCode
    atEnd
    beginInstance:size: (for use by storeDataOn: methods)
    beginReference: (for use by readDataFrom:size: methods)
    close
    next
    next:
    nextPut:
    nextPutAll:
    reset
    setType:
    size

NOTE: A DataStream should be treated as a read-stream *or* as a
write-stream, *not* as a read/write-stream.

[TBD] We should be able to make this much faster via tight-loop
byte-string I/O. It looks like FileStream (and WriteStream)
nextPutAll: do a reasonable job *if* it doesn''t have to push the
writeLimit, in which case it iterates with nextPut:. It could in many
cases set the writeLimit and then use the fast case
(replaceFrom:to:with:startingAt:), or fill a buffer at at time via
the fast case working on a substring.
    This approach would handle Strings, ByteArrays, and all other
variable-byte classes. If(nextPutAll: aCollection) in some cases
still reverts to (aCollection do: [:e | self nextPut: e]), then we''d
want to make Obj respond to do:. Then we could speed up inner
loop activities like nextPutInt32:.

[TBD] Every DataStream should begin with 4 signature bytes.
"on:" should emit or check the signature. But the current mechanism doesn''t always
know when the stream is started or ended.

[TBD] Cf. notes in DataStream>>beginInstance:size: and
Object>>readDataFrom:size:.

[TBD] We could save disk space & I/O time by using short, 1-byte size
fields whenever possible. E.g. almost all Symbols are shorter than
256 chars. We could do this either by (1) using different typeID codes
to indicate when a 1-byte length follows, a scheme which could still
read all the old files but would take more code, or (2) a
variable-length code for sizes.
    -- 11/15/92 jhm'!


!DataStream methodsFor: 'all'!
atEnd
    "Answer true if the stream is at the end."

    ^ byteStream atEnd! !

!DataStream methodsFor: 'all' stamp: '6/9/97 08:14 tk'!
beginInstance: aClass size: anInteger
    "This is for use by storeDataOn: methods.
     Cf. Object>>storeDataOn:."

        "Addition of 1 seems to make extra work, since readInstance
        has to compensate.  Here for historical reasons dating back
        to Kent Beck's original implementation in late 1988.

        In ReferenceStream, class is just 5 bytes for shared symbol.

        SmartRefStream puts out the names and number of class's instances variables for checking."

    byteStream nextNumber: 4 put: anInteger + 1.

    self nextPut: aClass name! !

!DataStream methodsFor: 'all'!
beginReference: anObject
    "We’re starting to read anObject. Remember it and its reference
     position (if we care; ReferenceStream cares). Answer the
     reference position."

    ^ 0! !

!DataStream methodsFor: 'all'!
byteStream
    ^ byteStream! !

!DataStream methodsFor: 'all' stamp: 'tk 8/16/96'!
checkForPaths: anObject
    "After an object is fully internalized, it should have no PathFromHome in it.    The only exception is Array, as pointed to by an IncomingObjects.  "
    | pfh |
    pfh _ Smalltalk at: #PathFromHome ifAbsent: [^ self].
    1 to: anObject class instSize do:
        [:i | (anObject instVarAt: i) class == pfh ifTrue: [
            self error: 'Unresolved Path']].
! !

!DataStream methodsFor: 'all'!
close
    "Close the stream."

    | bytes |
    byteStream closed
        ifFalse: [
            bytes _ byteStream position.
            byteStream close]
        ifTrue: [bytes _ 'unknown'].
    ^ bytes! !

!DataStream methodsFor: 'all'!
errorWriteReference: anInteger
    "PRIVATE -- Raise an error because this case of nextPut:’s perform:
     shouldn't be called. -- 11/15/92 jhm"

    self error: 'This should never be called'! !

!DataStream methodsFor: 'all'!
flush
    "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm"

    ^ byteStream flush! !

!DataStream methodsFor: 'all'!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.
     Overridden by ReferenceStream."

    ^ 0! !

!DataStream methodsFor: 'all'!
internalize: externalObject
    "PRIVATE -- We just read externalObject. Give it a chance to
        internalize. Return the internalized object."

    ^ externalObject comeFullyUpOnReload! !

!DataStream methodsFor: 'all' stamp: 'tk 7/24/97 18:29'!
next
    "Answer the next object in the stream."
    | type selector anObject isARefType pos |

    type _ byteStream next.
    type ifNil: [pos _ byteStream position.    "absolute!!!!"
        byteStream close.    "clean up"
        byteStream position = 0
            ifTrue: [self error: 'The file did not exist in this directory']
            ifFalse: [self error: 'Unexpected end of object file'].
        pos.    "so can see it in debugger"
        ^ nil].
    type = 0 ifTrue: [pos _ byteStream position.    "absolute!!!!"
        byteStream close.    "clean up"
        self error: 'Expected start of object, but found 0'.
        ^ nil].
    isARefType _ self noteCurrentReference: type.
    selector _ #(readNil readTrue readFalse readInteger
            readString readSymbol readByteArray
            readArray readInstance readReference readBitmap
            readClass readUser readFloat readRectangle readShortInst) at: type.
    anObject _ self perform: selector. "A method that recursively
        calls next (readArray, readInstance, objectAt:) must save &
        restore the current reference position."
    false ifTrue: ["So Senders will find the perform: here"
            self readNil; readTrue; readFalse; readInteger;
            readString; readSymbol; readByteArray;
            readArray; readInstance; readReference; readBitmap;
            readClass; readUser; readFloat; readRectangle; readShortInst].
    isARefType ifTrue: [self beginReference: anObject].

    "After reading the externalObject, internalize it.
     #readReference is a special case. Either:
       (1) We actually have to read the object, recursively calling
           next, which internalizes the object.
       (2) We just read a reference to an object already read and
           thus already interalized.
     Either way, we must not re-internalize the object here."
    selector == #readReference ifFalse:
        [anObject _ self internalize: anObject.
        self checkForPaths: anObject].
    ^ anObject! !

!DataStream methodsFor: 'all'!
next: anInteger
    "Answer an Array of the next anInteger objects in the stream."
    | array |

    array _ Array new: anInteger.
    1 to: anInteger do: [:i |
        array at: i put: self next].
    ^ array! !

!DataStream methodsFor: 'all' stamp: 'tk 11/24/97 16:31'!
nextAndClose
    "Speedy way to grab one object.  Only use when we are inside an object binary file.  Do not use for the start of a SmartRefStream mixed code-and-object file."

    | obj |
    byteStream peek = 4 ifFalse: ["Try to fix the user's sins..."
        self inform: 'Should be using fileInObjectAndCode'.
        byteStream ascii.
        byteStream fileIn.
        obj _ SmartRefStream scannedObject.
        SmartRefStream scannedObject: nil.
        ^ obj].

    obj _ self next.
    self close.
    ^ obj! !

!DataStream methodsFor: 'all' stamp: 'tk 3/13/98 22:16'!
nextPut: anObject
    "Write anObject to the receiver stream. Answer anObject.
     NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectToStoreOnDataStream) isn't (e.g. CompiledMethod and ViewState), then we should remember its externalized form
 but not add to 'references'. Putting that object again should just put its
 external form again. That's more compact and avoids seeks when reading.
 But we just do the simple thing here, allowing backward-references for
 non-reference types like nil. So objectAt: has to compensate. Objects that
 externalize nicely won't contain the likes of ViewStates, so this shouldn't
 hurt much.
     : writeReference: -> errorWriteReference:."
    | typeID selector objectToStore |

    typeID _ self typeIDFor: anObject.
    (self tryToPutReference: anObject typeID: typeID)
        ifTrue: [^ anObject].

    objectToStore _ (self objectIfBlocked: anObject) objectToStoreOnDataStream.
    objectToStore == anObject ifFalse: [typeID _ self typeIDFor: objectToStore].

    byteStream nextPut: typeID.
    selector _ #(writeNil: writeTrue: writeFalse: writeInteger:
        writeString: writeSymbol: writeByteArray:
        writeArray: writeInstance: errorWriteReference: writeBitmap:
        writeClass: writeUser: writeFloat: writeRectangle: == "dummy 16" ) at: typeID.
    self perform: selector with: objectToStore.

    ^ anObject! !

!DataStream methodsFor: 'all'!
nextPutAll: aCollection
    "Write each of the objects in aCollection to the
     receiver stream. Answer aCollection."

    ^ aCollection do: [:each | self nextPut: each]! !

!DataStream methodsFor: 'all'!
noteCurrentReference: typeID
    "PRIVATE -- If we support references for type typeID, remember
     the current byteStream position so we can add the next object to
     the ‘objects’ dictionary, and return true. Else return false.
     This method is here to be overridden by ReferenceStream"

    ^ false! !

!DataStream methodsFor: 'all' stamp: '
    6/9/97'!
objectAt: anInteger
    "PRIVATE -- Read & return the object at a given stream position.  08:18 tk  anInteger is a relative file position. "
    | savedPosn anObject refPosn |

    savedPosn _ byteStream position.    "absolute"
    refPosn _ self getCurrentReference.    "relative position"

    byteStream position: anInteger + basePos.    "was relative"
    anObject _ self next.

    self setCurrentReference: refPosn.    "relative position"
    byteStream position: savedPosn.        "absolute"
    ^ anObject! !

!DataStream methodsFor: 'all' stamp: 'tk 3/13/98 22:16'!
objectIfBlocked: anObject
    "We don't do any blocking"

    ^ anObject! !

!DataStream methodsFor: 'all' stamp: '6/9/97 08:46 tk'!
outputReference: referencePosn
    "PRIVATE -- Output a reference to the object at integer stream position referencePosn (relative to basePos). To output a weak reference to an object not yet written, supply (self vacantRef) for referencePosn."

    byteStream nextPut: 10. "reference typeID"
    byteStream nextNumber: 4 put: referencePosn    "relative position"! !

!DataStream methodsFor: 'all' stamp: '6/9/97 08:32 tk'!
readArray
    "PRIVATE -- Read the contents of an Array.
     We must do beginReference: here after instantiating the Array
     but before reading its contents, in case the contents reference
     the Array. beginReference: will be sent again when we return to
     next, but that's ok as long as we save and restore the current
     reference position over recursive calls to next."
    | count array refPosn |

    count _ byteStream nextNumber: 4.

    refPosn _ self beginReference: (array _ Array new: count).        "relative pos"
    1 to: count do: [:i |
        array at: i put: self next].
    self setCurrentReference: refPosn.        "relative pos"
    ^ array! !

!DataStream methodsFor: 'all'!
readBitmap
    "PRIVATE -- Read the contents of a Bitmap."

    ^ Bitmap newFromStream: byteStream
    "Note that the reader knows that the size is in long words, but the data is in bytes."! !

!DataStream methodsFor: 'all'!
readBoolean
    "PRIVATE -- Read the contents of a Boolean.
     This is here only for compatibility with old data files."

    ^ byteStream next ~= 0! !

!DataStream methodsFor: 'all'!
readByteArray
    "PRIVATE -- Read the contents of a ByteArray."
    | count buffer |

    count _ byteStream nextNumber: 4.
    ^ (ByteArray new: count)
        replaceFrom: 1 to: count with: (byteStream next: count)! !

!DataStream methodsFor: 'all' stamp: 'tk 3/24/98 10:29'!
readClass
    "Should never be executed because a DiskProxy, not a clas comes in."

    ^ self error: 'Classes should be filed in'! !

!DataStream methodsFor: 'all'!
readFalse
    "PRIVATE -- Read the contents of a False."

    ^ false! !

!DataStream methodsFor: 'all'!
readFloat
    "PRIVATE -- Read the contents of a Float.
     This is the fast way to read a Float.
     We support 8-byte Floats here.  Non-IEEE"

    | new |
    new _ Float new: 2.        "To get an instance"
    new at: 1 put: (byteStream nextNumber: 4).
    new at: 2 put: (byteStream nextNumber: 4).
    ^ new! !

!DataStream methodsFor: 'all'!
readFloatString
    "PRIVATE -- Read the contents of a Float string.
     This is the slow way to read a Float--via its string rep’n.
     It's here for compatibility with old data files."

    ^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! !

!DataStream methodsFor: 'all' stamp: 'tk 1/8/97'!
readInstance
    "PRIVATE -- Read the contents of an arbitrary instance.
     ASSUMES: readDataFrom:size: sends me beginReference: after it
       instantiates the new object but before reading nested objects.
     NOTE: We must restore the current reference position after
       recursive calls to next.
    Let the instance, not the class read the data.  "
    | instSize aSymbol refPosn anObject newClass |

    instSize _ (byteStream nextNumber: 4) - 1.
    refPosn _ self getCurrentReference.
    aSymbol _ self next.
    newClass _ Smalltalk at: aSymbol asSymbol.
    anObject _ newClass isVariable     "Create object here"
            ifFalse: [newClass basicNew]
            ifTrue: [newClass basicNew: instSize - (newClass instSize)].
    self setCurrentReference: refPosn.  "before readDataFrom:size:"
    anObject _ anObject readDataFrom: self size: instSize.
    self setCurrentReference: refPosn.  "before returning to next"
    ^ anObject! !

!DataStream methodsFor: 'all'!
readInteger
    "PRIVATE -- Read the contents of a SmallInteger."

    ^ byteStream nextInt32    "signed!!!!!!"! !

!DataStream methodsFor: 'all'!
readNil
    "PRIVATE -- Read the contents of an UndefinedObject."

    ^ nil! !

!DataStream methodsFor: 'all' stamp: ' 6/9/97'!
readRectangle
    "Read a compact Rectangle.  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  They will not come here.  17:22 tk"

    "Encoding is four 12-bit signed numbers.  48 bits in next 6 bytes.  17:24 tk"
    | acc left top right bottom |
    acc _ byteStream nextNumber: 3.
    left _ acc bitShift: -12.
    (left bitAnd: 16r800) ~= 0 ifTrue: [left _ left - 16r1000].    "sign"
    top _ acc bitAnd: 16rFFF.
    (top bitAnd: 16r800) ~= 0 ifTrue: [top _ top - 16r1000].    "sign"

    acc _ byteStream nextNumber: 3.
    right _ acc bitShift: -12.
    (right bitAnd: 16r800) ~= 0 ifTrue: [right _ right - 16r1000].    "sign"
    bottom _ acc bitAnd: 16rFFF.
    (bottom bitAnd: 16r800) ~= 0 ifTrue: [bottom _ bottom - 16r1000].    "sign"

    ^ Rectangle left: left right: right top: top bottom: bottom
! !

!DataStream methodsFor: 'all' stamp: ' 6/9/97'!
readReference
    "PRIVATE -- Read the contents of an object reference. Cf. outputReference:.
    11/15/92 jhm: Support weak references.
    08:09 tk Data on file is relative to base position (where DataStream took over)."
    | referencePosition |

    ^ (referencePosition _ (byteStream nextNumber: 4)) = self vacantRef    "relative"
        ifTrue:  [nil]
        ifFalse: [self objectAt: referencePosition]        "relative pos"! !

!DataStream methodsFor: 'all' stamp: 'tk 1/8/97'!
readShortInst
    "Read the contents of an arbitrary instance that has a short header.
     ASSUMES: readDataFrom:size: sends me beginReference: after it
       instantiates the new object but before reading nested objects.
     NOTE: We must restore the current reference position after
       recursive calls to next.
    Let the instance, not the class read the data.  "
    | instSize aSymbol refPosn anObject newClass |

    instSize _ (byteStream next) - 1.    "one byte of size"
    refPosn _ self getCurrentReference.
    aSymbol _ self readShortRef.    "class symbol in two bytes of file pos"
    newClass _ Smalltalk at: aSymbol asSymbol.
    anObject _ newClass isVariable     "Create object here"
            ifFalse: [newClass basicNew]
            ifTrue: [newClass basicNew: instSize - (newClass instSize)].
    self setCurrentReference: refPosn.  "before readDataFrom:size:"
    anObject _ anObject readDataFrom: self size: instSize.
    self setCurrentReference: refPosn.  "before returning to next"
    ^ anObject! !

!DataStream methodsFor: 'all' stamp: '6/10/97 17:03 tk'!
readShortRef
    "Read an object reference from two bytes only.  Original object must be in first 65536 bytes of the file."
    | referencePosition |

    ^ (referencePosition _ (byteStream nextNumber: 2)) = self vacantRef    "relative"
        ifTrue:  [nil]
        ifFalse: [self objectAt: referencePosition]        "relative pos"! !

!DataStream methodsFor: 'all'!
readString
    "PRIVATE -- Read the contents of a String."

    ^ byteStream nextString! !

!DataStream methodsFor: 'all'!
readSymbol
    "PRIVATE -- Read the contents of a Symbol."

    ^ self readString asSymbol! !

!DataStream methodsFor: 'all'!
readTrue
    "PRIVATE -- Read the contents of a True."

    ^ true! !

!DataStream methodsFor: 'all'!
readUser
    "Reconstruct both the private class and the instance.  7/29/96 tk"
    | instSize aSymbol refPosn anObject |

    anObject _ self readInstance.        "Will create new unique class"
    ^ anObject! !

!DataStream methodsFor: 'all'!
reset
    "Reset the stream."

    byteStream reset! !

!DataStream methodsFor: 'all' stamp: 'tk 5/29/97'!
rootObject
    "Return the object at the root of the tree we are filing out.  "

    ^ topCall! !

!DataStream methodsFor: 'all' stamp: 'tk 5/29/97'!
rootObject: anObject
    "Return the object at the root of the tree we are filing out.  "

    topCall _ anObject! !

!DataStream methodsFor: 'all'!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.
     Noop here. Cf. ReferenceStream."! !

!DataStream methodsFor: 'all' stamp: '6/9/97 08:03 di'!
setStream: aStream
    "PRIVATE -- Initialization method."

    aStream binary.
    basePos _ aStream position.    "Remember where we start.  Earlier part of file contains a class or method file-in.  Allow that to be edited.  We don't deal in absolute file locations."
    byteStream _ aStream.! !

!DataStream methodsFor: 'all'!
size
    "Answer the stream's size."

    ^ byteStream size! !

!DataStream methodsFor: 'all'!
tryToPutReference: anObject typeID: typeID
    "PRIVATE -- If we support references for type typeID, and if
       anObject already appears in my output stream, then put a
       reference to the place where anObject already appears. If we
       support references for typeID but didn’t already put anObject,
       then associate the current stream position with anObject in
       case one wants to nextPut: it again.
     Return true after putting a reference; false if the object still
       needs to be put.
     For DataStream this is trivial. ReferenceStream overrides this."

    ^ false! !

!DataStream methodsFor: 'all' stamp: 'tk 3/15/98 12:35'!
typeIDFor: anObject
    "Return the typeID for anObject's class.  This is where the tangle of objects is clipped to stop everything from going out.
    Classes can control their instance variables by defining objectToStoreOnDataStream.
    Any object in blockers is not written out.  See ReferenceStream.objectIfBlocked: and DataStream nextPut:.
    Morphs do not write their owners.  See Morph.storeDataOn:   Each morph tells itself to 'prepareToBeSaved' before writing out."

    ^ TypeMap at: anObject class ifAbsent: [9 "instance of any normal class"]
"See DataStream initialize.  nil=1. true=2. false=3. a SmallInteger=4. a String=5. a Symbol=6.  a ByteArray=7. an Array=8. other = 9.  a Bitmap=11. a Metaclass=12. a Float=14.  a Rectangle=15. any instance that can have a short header=16."! !

!DataStream methodsFor: 'all' stamp: 'jhm 11/15/92'!
vacantRef
    "Answer the magic 32-bit constant we use ***ON DISK*** as a stream 'reference
     position' to identify a reference that's not yet filled in. This must be a
     value that won't be used as an ordinary reference. Cf. outputReference: and
     readReference. --
     NOTE: We could use a different type ID for vacant-refs rather than writing
        object-references with a magic value. (The type ID and value are
        overwritten by ordinary object-references when weak refs are fullfilled.)"

    ^ -1! !

!DataStream methodsFor: 'all'!
writeArray: anArray
    "PRIVATE -- Write the contents of an Array."

    byteStream nextNumber: 4 put: anArray size.
    self nextPutAll: anArray.! !

!DataStream methodsFor: 'all' stamp: 'jm 12/3/97 21:39'!
writeBitmap: aBitmap
    "PRIVATE -- Write the contents of a Bitmap."

    (byteStream isKindOf: DummyStream) ifTrue: [^ self].
    aBitmap writeOn: byteStream
    "Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words."! !

!DataStream methodsFor: 'all'!
writeBoolean: aBoolean
    "PRIVATE -- Write the contents of a Boolean.
     This method is now obsolete."

    byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])! !

!DataStream methodsFor: 'all' stamp: 'jm 12/3/97 20:45'!
writeByteArray: aByteArray
    "PRIVATE -- Write the contents of a ByteArray."

    (byteStream isKindOf: DummyStream) ifTrue: [^ self].
    byteStream nextNumber: 4 put: aByteArray size.
    "May have to convert types here..."
    byteStream nextPutAll: aByteArray.! !

!DataStream methodsFor: 'all' stamp: 'tk 3/24/98 10:27'!
writeClass: aClass
    "Write out a DiskProxy for the class.  It will look up the class's name in Smalltalk in the new sustem.  Never write classes or methodDictionaries as objects.  For novel classes, front part of file is a fileIn of the new class."

    "This method never executed because objectToStoreOnDataStream returns a DiskProxy.  See DataStream.nextPut:"
    ^ self error: 'Write a DiskProxy instead'! !

!DataStream methodsFor: 'all'!
writeFalse: aFalse
    "PRIVATE -- Write the contents of a False."! !

!DataStream methodsFor: 'all'!
writeFloat: aFloat
    "PRIVATE -- Write the contents of a Float.
      We support 8-byte Floats here."

    byteStream nextNumber: 4 put: (aFloat at: 1).
    byteStream nextNumber: 4 put: (aFloat at: 2).
! !

!DataStream methodsFor: 'all'!
writeFloatString: aFloat
    "PRIVATE -- Write the contents of a Float string.
     This is the slow way to write a Float--via its string rep’n."

    self writeByteArray: (aFloat printString)! !

!DataStream methodsFor: 'all'!
writeInstance: anObject
    "PRIVATE -- Write the contents of an arbitrary instance."

    ^ anObject storeDataOn: self! !

!DataStream methodsFor: 'all'!
writeInteger: anInteger
    "PRIVATE -- Write the contents of a SmallInteger."

    byteStream nextInt32Put: anInteger    "signed!!!!!!!!!!"! !

!DataStream methodsFor: 'all'!
writeNil: anUndefinedObject
    "PRIVATE -- Write the contents of an UndefinedObject."! !

!DataStream methodsFor: 'all' stamp: 'jm 7/31/97 16:16'!
writeRectangle: anObject
    "Write the contents of a Rectangle.  See if it can be a compact Rectangle (type=15).  Rectangles with values outside +/- 2047 were stored as normal objects (type=9).  17:22 tk"

    | ok right bottom top left acc |
    ok _ true.
    (right _ anObject right) > 2047 ifTrue: [ok _ false].
    right < -2048 ifTrue: [ok _ false].
    (bottom _ anObject bottom) > 2047 ifTrue: [ok _ false].
    bottom < -2048 ifTrue: [ok _ false].
    (top _ anObject top) > 2047 ifTrue: [ok _ false].
    top < -2048 ifTrue: [ok _ false].
    (left _ anObject left) > 2047 ifTrue: [ok _ false].
    left < -2048 ifTrue: [ok _ false].
    ok _ ok & left isInteger & right isInteger & top isInteger & bottom isInteger.

    ok ifFalse: [
        byteStream skip: -1; nextPut: 9; skip: 0. "rewrite type to be normal instance"
        ^ anObject storeDataOn: self].

    acc _ ((left bitAnd: 16rFFF) bitShift: 12) + (top bitAnd: 16rFFF).
    byteStream nextNumber: 3 put: acc.
    acc _ ((right bitAnd: 16rFFF) bitShift: 12) + (bottom bitAnd: 16rFFF).
    byteStream nextNumber: 3 put: acc.! !

!DataStream methodsFor: 'all' stamp: 'jm 12/3/97 20:45'!
writeString: aString
    "PRIVATE -- Write the contents of a String."

    (byteStream isKindOf: DummyStream) ifTrue: [^ self].
    aString size < 16384
        ifTrue: [byteStream nextStringPut: aString]
        ifFalse: [self writeByteArray: aString].    "takes more space"! !

!DataStream methodsFor: 'all'!
writeSymbol: aSymbol
    "PRIVATE -- Write the contents of a Symbol."

    self writeString: aSymbol! !

!DataStream methodsFor: 'all'!
writeTrue: aTrue
    "PRIVATE -- Write the contents of a True."! !

!DataStream methodsFor: 'all'!
writeUser: anObject
    "Write the contents of an arbitrary User instance (and its devoted class)."
    " 7/29/96 tk"

    "If anObject is an instance of a unique user class, will lie and say it has a generic class"
    ^ anObject storeDataOn: self! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DataStream class
    instanceVariableNames: ''!

!DataStream class methodsFor: 'all'!
example
    "An example and test of DataStream/ReferenceStream.
     11/19/92 jhm: Use self testWith:."
    "DataStream example"
    "ReferenceStream example"
    | input sharedPoint |

    "Construct the test data."
    input _ Array new: 9.
    input at: 1 put: nil.
    input at: 2 put: true.
    input at: 3 put: (Form extent: 63 @ 50 depth: 8).
        (input at: 3) fillWithColor: Color lightBlue.
    input at: 4 put: #(3 3.0 'three').
    input at: 5 put: false.
    input at: 6 put: 1024 @ -2048.
    input at: 7 put: #x.
    input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
    input at: 9 put: sharedPoint.

    "Write it out, read it back, and return it for inspection."
    ^ self testWith: input! !

!DataStream class methodsFor: 'all'!
exampleWithPictures
    "DataStream exampleWithPictures"
    | file result |
    file _ FileStream fileNamed: 'Test-Picture'.
    file binary.
    (DataStream on: file) nextPut: (Form fromUser).
    file close.

    file _ FileStream fileNamed: 'Test-Picture'.
    file binary.
    result _ (DataStream on: file) next.
    file close.
    result display.
    ^ result! !

!DataStream class methodsFor: 'all'!
fileNamed: aString
    "Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

    | strm |
    strm _ self on: (FileStream fileNamed: aString).        "will be binary"
    strm byteStream setFileTypeToObject.
        "Type and Creator not to be text, so can attach correctly to an email msg"
    ^ strm! !

!DataStream class methodsFor: 'all' stamp: '6/10/97 16:51 tk'!
initialize
    "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.
     See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
    "DataStream initialize"

    | refTypes t |
    refTypes _ OrderedCollection new.
    t _ TypeMap _ Dictionary new: 30. "sparse for fast hashing"

    t at: UndefinedObject put: 1.   refTypes add: 0.
    t at: True put: 2.   refTypes add: 0.
    t at: False put: 3.   refTypes add: 0.
    t at: SmallInteger put: 4.     refTypes add: 0.
    t at: String put: 5.   refTypes add: 1.
    t at: Symbol put: 6.   refTypes add: 1.
    t at: ByteArray put: 7.   refTypes add: 1.
        "Does anything use this?"
    t at: Array put: 8.   refTypes add: 1.
    "(type ID 9 is for arbitrary instances, cf. typeIDFor:)"
        refTypes add: 1.
    "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
        refTypes add: 0.
    t at: Bitmap put: 11.   refTypes add: 1.
    t at: Metaclass put: 12.   refTypes add: 0.
    "Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
        refTypes add: 1.
    t at: Float put: 14.  refTypes add: 1.
    t at: Rectangle put: 15.  refTypes add: 1.    "Allow compact Rects."
    "type ID 16 is an instance with short header.  See beginInstance:size:"
        refTypes add: 1.
    "t at:  put: 17.  refTypes add: 0."
    ReferenceStream refTypes: refTypes.    "save it"! !

!DataStream class methodsFor: 'all' stamp: 'di 2/15/98 14:03'!
new
    ^ self basicNew! !

!DataStream class methodsFor: 'all'!
newFileNamed: aString
    "Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

    | strm |
    strm _  self on: (FileStream newFileNamed: aString).        "will be binary"
    strm byteStream setFileTypeToObject.
        "Type and Creator not to be text, so can attach correctly to an email msg"
    ^ strm! !

!DataStream class methodsFor: 'all'!
oldFileNamed: aString
    "Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream oldFileNamed: 'test.obj'.
^ rr nextAndClose.
"

    | strm ff |
    ff _ FileStream oldFileOrNoneNamed: aString.
    ff ifNil: [^ nil].
    strm _ self on: (ff binary).
    ^ strm! !

!DataStream class methodsFor: 'all' stamp: 'di 6/24/97 00:18'!
on: aStream
    "Open a new DataStream onto a low-level I/O stream."

    ^ self basicNew setStream: aStream
        "aStream binary is in setStream:"
! !

!DataStream class methodsFor: 'all' stamp: 'jm 12/3/97 19:36'!
testWith: anObject
    "As a test of DataStream/ReferenceStream, write out anObject and read it back.
    11/19/92 jhm: Set the file type. More informative file name."
    "DataStream testWith: 'hi'"
    "ReferenceStream testWith: 'hi'"
    | file result |

    file _ FileStream fileNamed: (self name, ' test').
    file binary.
    (self on: file) nextPut: anObject.
    file close.

    file _ FileStream fileNamed: (self name, ' test').
    file binary.
    result _ (self on: file) next.
    file close.
    ^ result! !
Magnitude subclass: #Date
    instanceVariableNames: 'day year '
    classVariableNames: 'DaysInMonth FirstDayOfMonth MonthNames SecondsInDay WeekDayNames '
    poolDictionaries: ''
    category: 'Numeric-Magnitudes'!
!Date commentStamp: 'di 5/22/1998 16:33' prior: 0!
Date comment:
'I represent a date. My printing format consists of an array of six elements.

The first three elements contain the numbers 1, 2, 3, in any order. 1 indicates that the day appears in this position, 2 indicates that the month appears in this position, and 3 indicates that the year appears in this position.

The fourth element is the ascii value of the character separator or the character itself.

The fifth element is the month format, where 1 indicates print as a number, 2 indicates print the first three characters, and 3 indicates print the entire name.

The six element is the year format, where 1 indicates print as a number, and 2 indicates print the number modulo 100.

Examples:
    #(1 2 3 32 2 1) prints as 12 Dec 1981
    #(2 1 3 $/ 1 2) prints as 12/12/81'!


!Date methodsFor: 'accessing'!
day
    "Answer the day of the year represented by the receiver."

    ^day! !

!Date methodsFor: 'accessing'!
leap
    "Answer whether the receiver's year is a leap year."

    ^Date leapYear: year! !

!Date methodsFor: 'accessing'!
monthIndex
    "Answer the index of the month in which the receiver falls."

    | leap firstDay |
    leap _ self leap.
    12 to: 1 by: -1 do:
        [ :monthIndex |
            firstDay _ (FirstDayOfMonth at: monthIndex)
                            + (monthIndex > 2 ifTrue: [leap] ifFalse: [0]).
            firstDay<= day
                ifTrue: [^monthIndex]].
    self error: 'illegal month'! !

!Date methodsFor: 'accessing'!
monthName
    "Answer the name of the month in which the receiver falls."

    ^MonthNames at: self monthIndex! !

!Date methodsFor: 'accessing'!
weekday
    "Answer the name of the day of the week on which the receiver falls."

    ^WeekDayNames at: self weekdayIndex! !

!Date methodsFor: 'accessing'!
year
    "Answer the year in which the receiver falls."

    ^year! !


!Date methodsFor: 'arithmetic'!
addDays: dayCount
    "Answer a Date that is dayCount days after the receiver."

    ^Date newDay: day + dayCount
          year: year! !

!Date methodsFor: 'arithmetic'!
subtractDate: aDate
    "Answer the number of days between the receiver and aDate."

    year = aDate year
        ifTrue: [^day - aDate day]
        ifFalse: [^year - 1 // 4 - (aDate year // 4) + day
                        + aDate daysLeftInYear + (year - 1 - aDate year * 365)]! !

!Date methodsFor: 'arithmetic'!
subtractDays: dayCount
    "Answer a Date that is dayCount days before the receiver."

    ^Date newDay: day - dayCount year: year! !


!Date methodsFor: 'comparing'!
< aDate
    "Answer whether aDate precedes the date of the receiver."

    year = aDate year
        ifTrue: [^day < aDate day]
        ifFalse: [^year < aDate year]! !

!Date methodsFor: 'comparing'!
= aDate
    "Answer whether aDate is the same day as the receiver."

    self species = aDate species
        ifTrue: [^day = aDate day & (year = aDate year)]
        ifFalse: [^false]! !

!Date methodsFor: 'comparing'!
hash
    "Hash is reimplemented because = is implemented."

    ^(year hash bitShift: 3) bitXor: day! !


!Date methodsFor: 'inquiries'!
dayOfMonth
    "Answer which day of the month is represented by the receiver."

    ^day - (self firstDayOfMonthIndex: self monthIndex) + 1! !

!Date methodsFor: 'inquiries'!
daysInMonth
    "Answer the number of days in the month represented by the receiver."

    ^(DaysInMonth at: self monthIndex)
        + (self monthIndex = 2
                ifTrue: [self leap]
                ifFalse: [0])! !

!Date methodsFor: 'inquiries'!
daysInYear
    "Answer the number of days in the year represented by the receiver."

    ^Date daysInYear: self year! !

!Date methodsFor: 'inquiries'!
daysLeftInYear
    "Answer the number of days in the year after the date of the receiver."

    ^self daysInYear - self day! !

!Date methodsFor: 'inquiries'!
firstDayOfMonth
    "Answer the index of the day of the year that is the first day of the
    receiver's month."

    ^self firstDayOfMonthIndex: self monthIndex! !

!Date methodsFor: 'inquiries'!
previous: dayName
    "Answer the previous date whose weekday name is dayName."

    ^self subtractDays: 7 + self weekdayIndex - (Date dayOfWeek: dayName) \\ 7! !


!Date methodsFor: 'converting'!
asSeconds
    "Answer the seconds between a time on 1 January 1901 and the same
    time in the receiver's day."

    ^SecondsInDay * (self subtractDate: (Date newDay: 1 year: 1901))! !


!Date methodsFor: 'printing' stamp: 'tk 4/10/1998 09:20'!
mmddyy
    "Please use mmddyyyy instead, so dates in 2000 will be unambiguous"
    "Answer the receiver rendered in standard fmt mm/dd/yy. 1/17/96 sw.  2/1/96 sw Fixed to show day of month, not day.  Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96"

    "Date today mmddyy"

    ^ self printFormat: #(2 1 3 $/ 1 2)! !

!Date methodsFor: 'printing' stamp: 'tk 1/27/98 08:30'!
mmddyyyy
    "Answer the receiver rendered in standard fmt mm/dd/yyyy.  Good for avoiding year 2000 bugs.  Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96"

    "Date today mmddyyyy"

    ^ self printFormat: #(2 1 3 $/ 1 1)! !

!Date methodsFor: 'printing'!
printFormat: formatArray
    "Answer a String describing the receiver using the format denoted by the
    argument, formatArray."

    | aStream |
    aStream _ WriteStream on: (String new: 16).
    self printOn: aStream format: formatArray.
    ^aStream contents! !

!Date methodsFor: 'printing'!
printOn: aStream

    self printOn: aStream format: #(1 2 3 $  3 1 )! !

!Date methodsFor: 'printing'!
printOn: aStream format: formatArray
    "Print a description of the receiver on aStream using the format denoted
    by the argument, formatArray:
        #(item item item sep monthfmt yearfmt twoDigits)
        items:  1=day  2=month  3=year  will appear in the order given,
        separated by sep which is eaither an ascii code or character.
        monthFmt:  1=09  2=Sep  3=September
        yearFmt:  1=1996  2=96
        digits:  (missing or)1=9  2=09.
    See the examples in printOn: and mmddyy"
    | monthIndex element monthFormat twoDigits monthDay |
    twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1].
    monthIndex _ self monthIndex.
    1 to: 3 do:
        [:elementIndex |
        element _ formatArray at: elementIndex.
        element = 1 ifTrue:
            [monthDay _ day - self firstDayOfMonth + 1.
            twoDigits & (monthDay < 10) ifTrue: [aStream nextPutAll: '0'].
                monthDay printOn: aStream].
        element = 2 ifTrue:
            [monthFormat _ formatArray at: 5.
            monthFormat = 1 ifTrue:
                [twoDigits & (monthIndex < 10) ifTrue: [aStream nextPutAll: '0'].
                monthIndex printOn: aStream].
            monthFormat = 2 ifTrue:
                [aStream nextPutAll: ((MonthNames at: monthIndex)
                                                copyFrom: 1 to: 3)].
            monthFormat = 3 ifTrue:
                [aStream nextPutAll: (MonthNames at: monthIndex)]].
        element = 3 ifTrue:
            [(formatArray at: 6) = 1
                ifTrue: [year printOn: aStream]
                ifFalse: [twoDigits & ((year \\ 100) < 10)
                            ifTrue: [aStream nextPutAll: '0'].
                        (year \\ 100) printOn: aStream]].
        elementIndex < 3 ifTrue:
            [(formatArray at: 4) ~= 0
                ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]! !

!Date methodsFor: 'printing'!
storeOn: aStream

    aStream nextPutAll: '(', self class name, ' readFromString: ';
        print: self printString;
        nextPut: $)! !


!Date methodsFor: 'private'!
day: dayInteger year: yearInteger

    day _ dayInteger.
    year _ yearInteger! !

!Date methodsFor: 'private'!
firstDayOfMonthIndex: monthIndex
    "Answer the day of the year (an Integer) that is the first day of my month"

    ^(FirstDayOfMonth at: monthIndex)
        + (monthIndex > 2
                ifTrue: [self leap]
                ifFalse: [0])! !

!Date methodsFor: 'private' stamp: 'jm 1/6/98 13:38'!
weekdayIndex
    "Monday=1, ... , Sunday=7"

    | yearIndex dayIndex |
    day < (self firstDayOfMonthIndex: 3)
        ifTrue:
            [yearIndex _ year - 1.
            dayIndex _ 307]
        ifFalse:
            [yearIndex _ year.
            dayIndex _ -58 - self leap].

    ^dayIndex + day + yearIndex + (yearIndex // 4)
                + (yearIndex // 400) - (yearIndex // 100) \\ 7 + 1! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Date class
    instanceVariableNames: ''!

!Date class methodsFor: 'class initialization'!
initialize
    "Initialize class variables representing the names of the months and days and
    the number of seconds, days in each month, and first day of each month."

    MonthNames _
        #(January February March April May June
            July August September October November December ).
    SecondsInDay _ 24 * 60 * 60.
    DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31 ).
    FirstDayOfMonth _ #(1 32 60 91 121 152 182 213 244 274 305 335 ).
    WeekDayNames _
        #(Monday Tuesday Wednesday Thursday Friday Saturday Sunday )

    "Date initialize."
! !


!Date class methodsFor: 'instance creation'!
fromDays: dayCount
    "Answer an instance of me which is dayCount days after January 1,
    1901."

    ^self
        newDay: 1 + (dayCount asInteger rem: 1461)
                            "There are 1461 days in a 4-year cycle.
                             2000 is a leap year, so no extra correction is necessary. "
        year: 1901 + ((dayCount asInteger quo: 1461) * 4)! !

!Date class methodsFor: 'instance creation'!
fromString: aString
    "Answer an instance of created from a string with format DD.MM.YYYY."

    | fields |
    fields := aString findTokens: './'.
    ^self newDay: (fields at: 1) asNumber month: (fields at: 2) asNumber year: (fields at: 3) asNumber! !

!Date class methodsFor: 'instance creation' stamp: 'tk 4/10/1998 06:40'!
newDay: day month: monthName year: year
    "Answer an instance of me which is the day'th day of the month named
     monthName in the year'th year. The year may be specified as the actual
     number of years since the beginning of the Roman calendar or the
     number of years since 1900.  **Note** two digit dates are always from 1900.
        1/1/01 will NOT mean 2001."
    "Tolerate a month index instead of a month name."

    | monthIndex daysInMonth firstDayOfMonth |
    year < 100 ifTrue: [^ self
            newDay: day
            month: monthName
            year: 1900 + year].
    monthIndex _ monthName isInteger
     ifTrue: [monthName] ifFalse: [self indexOfMonth: monthName].
    monthIndex = 2
        ifTrue: [daysInMonth _ (DaysInMonth at: monthIndex)
                        + (self leapYear: year)]
        ifFalse: [daysInMonth _ DaysInMonth at: monthIndex].
    monthIndex > 2
        ifTrue: [firstDayOfMonth _ (FirstDayOfMonth at: monthIndex)
                        + (self leapYear: year)]
        ifFalse: [firstDayOfMonth _ FirstDayOfMonth at: monthIndex].
    (day < 1 or: [day > daysInMonth])
        ifTrue: [self error: 'illegal day in month']
        ifFalse: [^self new day: day - 1 + firstDayOfMonth year: year]! !

!Date class methodsFor: 'instance creation'!
newDay: dayCount year: referenceYear
    "Answer an instance of me which is dayCount days after the beginning
    of the year referenceYear."

    | day year daysInYear |
    day _ dayCount.
    year _ referenceYear.
    [day > (daysInYear _ self daysInYear: year)]
        whileTrue:
            [year _ year + 1.
             day _ day - daysInYear].
    [day <= 0]
        whileTrue:
            [year _ year - 1.
             day _ day + (self daysInYear: year)].
    ^self new day: day year: year! !

!Date class methodsFor: 'instance creation'!
readFrom: aStream
    "Read a Date from the stream in any of the forms:
        <day> <monthName> <year>        (5 April 1982; 5-APR-82)
        <monthName> <day> <year>        (April 5, 1982)
        <monthNumber> <day> <year>    (4/5/82)"

    | day month |
    aStream peek isDigit ifTrue: [day _ Integer readFrom: aStream].
    [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
    aStream peek isLetter
        ifTrue:        "number/name... or name..."
            [month _ WriteStream on: (String new: 10).
            [aStream peek isLetter] whileTrue: [month nextPut: aStream next].
            month _ month contents.
            day isNil ifTrue:        "name/number..."
                [[aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
                day _ Integer readFrom: aStream]]
        ifFalse:        "number/number..."
            [month _ Date nameOfMonth: day.
            day _ Integer readFrom: aStream].
    [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1].
    ^self newDay: day month: month year: (Integer readFrom: aStream)

    "Date readFrom: (ReadStream on: '5APR82')"
! !

!Date class methodsFor: 'instance creation'!
today
    "Answer an instance of me representing the day and year right now."

    ^self dateAndTimeNow at: 1! !


!Date class methodsFor: 'general inquiries'!
dateAndTimeNow
    "Answer an Array whose first element is Date today and second element
    is Time now."

    ^Time dateAndTimeNow! !

!Date class methodsFor: 'general inquiries'!
dayOfWeek: dayName
    "Answer the index in a week, 1-7, of the day named dayName. Create an
    error notification if no such day exists."

    1 to: 7 do: [:index | (WeekDayNames at: index)
            = dayName ifTrue: [^index]].
    self error: dayName asString , ' is not a day of the week'! !

!Date class methodsFor: 'general inquiries'!
daysInMonth: monthName forYear: yearInteger
    "Answer the number of days in the month named monthName in the
    year yearInteger."

    ^(self newDay: 1
          month: monthName
          year: yearInteger) daysInMonth! !

!Date class methodsFor: 'general inquiries'!
daysInYear: yearInteger
    "Answer the number of days in the year, yearInteger."

    ^365 + (self leapYear: yearInteger)! !

!Date class methodsFor: 'general inquiries'!
firstWeekdayOfMonth: mn year: yr
    "Answer the weekday index (Sunday=1, etc) of the first day in the month named mn in the year yr."

    ^(self newDay: 1 month: mn year: yr) weekdayIndex + 7 \\ 7 + 1! !

!Date class methodsFor: 'general inquiries'!
indexOfMonth: monthName
    "Answer the index, 1-12, of the month monthName. Create an error
    notification if no such month exists."

    1 to: 12 do:
        [ :index |
            (monthName , '*' match: (MonthNames at: index))
                        ifTrue: [^index]].
    self error: monthName , ' is not a recognized month name'! !

!Date class methodsFor: 'general inquiries'!
leapYear: yearInteger
    "Answer 1 if the year yearInteger is a leap year; answer 0 if it is not."

    (yearInteger \\ 4 ~= 0 or: [yearInteger \\ 100 = 0 and: [yearInteger \\ 400 ~= 0]])
        ifTrue: [^0]
        ifFalse: [^1]! !

!Date class methodsFor: 'general inquiries'!
nameOfDay: dayIndex
    "Answer a symbol representing the name of the day indexed by
    dayIndex, 1-7."

    ^WeekDayNames at: dayIndex! !

!Date class methodsFor: 'general inquiries'!
nameOfMonth: monthIndex
    "Answer a String representing the name of the month indexed by
    monthIndex, 1-12."

    ^MonthNames at: monthIndex! !
StringHolder subclass: #Debugger
    instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames '
    classVariableNames: 'ContextStackKeystrokes ErrorRecursion '
    poolDictionaries: ''
    category: 'Interface-Debugger'!
!Debugger commentStamp: 'di 5/22/1998 16:33' prior: 0!
Debugger comment:
'I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. As a StringHolder, the string to be viewed is the interrupted method at some point in the sequence of message-sends that have been initiated but not completed.'!


!Debugger methodsFor: 'initialize' stamp: 'tm 5/10/1998 15:08'!
buildMVCDebuggerViewLabel: aString minSize: aPoint

    | topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView |
    self expandStack.
    topView _ StandardSystemView new model: self.
    topView borderWidth: 1.
    stackListView _ PluggableListView on: self
            list: #contextStackList
            selected: #contextStackIndex
            changeSelected: #toggleContextStackIndex:
            menu: #contextStackMenu:shifted:
            keystroke: #contextStackKey:from:.
        stackListView window: (0 @ 0 extent: 150 @ 50).
        topView addSubView: stackListView.
    stackCodeView _ PluggableTextView on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        stackCodeView window: (0 @ 0 extent: 150 @ 75).
        topView addSubView: stackCodeView below: stackListView.
    rcvrVarView _ PluggableListView on: self receiverInspector
            list: #fieldList
            selected: #selectionIndex
            changeSelected: #toggleIndex:
            menu: #fieldListMenu:
            keystroke: #inspectorKey:from:.
        rcvrVarView window: (0 @ 0 extent: 25 @ 50).
        topView addSubView: rcvrVarView below: stackCodeView.
    rcvrValView _ PluggableTextView on: self receiverInspector
            text: #contents accept: #accept:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        rcvrValView window: (0 @ 0 extent: 50 @ 50).
        topView addSubView: rcvrValView toRightOf: rcvrVarView.
    ctxtVarView _ PluggableListView on: self contextVariablesInspector
            list: #fieldList
            selected: #selectionIndex
            changeSelected: #toggleIndex:
            menu: #fieldListMenu:
            keystroke: #inspectorKey:from:.
        ctxtVarView window: (0 @ 0 extent: 25 @ 50).
        topView addSubView: ctxtVarView toRightOf: rcvrValView.
    ctxtValView _ PluggableTextView on: self contextVariablesInspector
            text: #contents accept: #accept:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:.
        ctxtValView window: (0 @ 0 extent: 50 @ 50).
        topView addSubView: ctxtValView toRightOf: ctxtVarView.
    topView label: aString.
    topView minimumSize: aPoint.
    ^ topView
! !

!Debugger methodsFor: 'initialize' stamp: 'jm 5/1/1998 17:47'!
buildMVCNotifierViewLabel: aString message: messageString minSize: aPoint

    | topView aStringHolderView |
    topView _ StandardSystemView new model: self.
    topView borderWidth: 1.
    aStringHolderView _ PluggableTextView on: self
        text: #contents
        accept: #doNothing:
        readSelection: #contentsSelection
        menu: #debugProceedMenu:.
    aStringHolderView
        editString: messageString;
        askBeforeDiscardingEdits: false.
    topView
        addSubView: aStringHolderView;
        label: aString;
        minimumSize: aPoint.
    ^ topView
! !

!Debugger methodsFor: 'initialize' stamp: 'di 5/6/1998 21:37'!
buildMorphicNotifierLabelled: label message: messageString
    | notifyPane window |
    window _ (SystemWindow labelled: label) model: self.

    notifyPane _ PluggableTextMorph on: self text: #contents accept: #doNothing:
        readSelection: #contentsSelection menu: #debugProceedMenu:.
    notifyPane editString: messageString;
        askBeforeDiscardingEdits: false.
    window addMorph: notifyPane frame: (0@0 corner: 1@1).

    ^ window openInWorldExtent: 350@116! !

!Debugger methodsFor: 'initialize'!
defaultBackgroundColor
    ^ #lightRed! !

!Debugger methodsFor: 'initialize' stamp: 'tm 5/10/1998 15:08'!
openFullMorphicLabel: labelString
    | window |
    self expandStack.
    window _ (SystemWindow labelled: labelString) model: self.

    window addMorph: (PluggableListMorph on: self list: #contextStackList
            selected: #contextStackIndex changeSelected: #toggleContextStackIndex:
            menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:)
        frame: (0@0 corner: 1@0.3).
    window addMorph: (PluggableTextMorph on: self
            text: #contents accept: #contents:notifying:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
        frame: (0@0.3 corner: 1@0.7).
    window addMorph: (PluggableListMorph on: self receiverInspector list: #fieldList
            selected: #selectionIndex changeSelected: #toggleIndex:
            menu: #fieldListMenu: keystroke: #inspectorKey:from:)
        frame: (0@0.7 corner: 0.2@1).
    window addMorph: (PluggableTextMorph on: self receiverInspector
            text: #contents accept: #accept:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
        frame: (0.2@0.7 corner: 0.5@1).
    window addMorph: (PluggableListMorph on: self contextVariablesInspector list: #fieldList
            selected: #selectionIndex changeSelected: #toggleIndex:
            menu: #fieldListMenu: keystroke: #inspectorKey:from:)
        frame: (0.5@0.7 corner: 0.7@1).
    window addMorph: (PluggableTextMorph on: self contextVariablesInspector
            text: #contents accept: #accept:
            readSelection: #contentsSelection menu: #codePaneMenu:shifted:)
        frame: (0.7@0.7 corner: 1@1).

    ^ window openInWorld
! !

!Debugger methodsFor: 'initialize' stamp: 'jm 5/1/1998 18:03'!
openFullNoSuspendLabel: aString
    "Create and schedule a full debugger with the given label. Do not terminate the current active process."

    | topView |
    topView _ self buildMVCDebuggerViewLabel: aString minSize: 300@200.
    topView controller openNoTerminate.
    ^ topView
! !

!Debugger methodsFor: 'initialize' stamp: 'di 5/4/1998 23:01'!
openNotifierContents: msgString label: label
    "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired. Do not terminate the current active process."
    | msg topView p newActiveProcess |
    Sensor flushKeyboard.
    (label beginsWith: 'Space is low')
        ifTrue: [msg _ self lowSpaceChoices, msgString]
        ifFalse: [msg _ msgString].

    World ifNotNil:
        [self buildMorphicNotifierLabelled: label message: msg.
        newActiveProcess _
            [[true] whileTrue: [World doOneCycle.  Processor yield]] newProcess
                    priority: Processor userSchedulingPriority.
        ^ newActiveProcess resume].

    Display fullScreen.
    Cursor normal show.
    topView _ self buildMVCNotifierViewLabel: label message: msg minSize: 350@((14 * 5) + 16).
    ScheduledControllers activeController
        ifNil: [p _ Display boundingBox center]
        ifNotNil: [p _ ScheduledControllers activeController view displayBox center].
    topView controller openNoTerminateDisplayAt: (p max: (200@60)).
    ^ topView
! !

!Debugger methodsFor: 'initialize'!
release

    interruptedProcess ~~ nil ifTrue: [interruptedProcess terminate].
    interruptedProcess _ nil.
    interruptedController _ nil.
    contextStack _ nil.
    contextStackTop _ nil.
    receiverInspector _ nil.
    contextVariablesInspector _ nil.
    Smalltalk installLowSpaceWatcher.  "restart low space handler"
    super release.! !


!Debugger methodsFor: 'accessing'!
contents
    "Depending on the current selection, different information is retrieved.
    Answer a string description of that information.  This information is the
    method in the currently selected context."

    contents == nil ifTrue: [^''].
    ^contents! !

!Debugger methodsFor: 'accessing' stamp: 'tk 12/6/97 21:31'!
contents: aText notifying: aController
    "The retrieved information has changed and its source must now be
    updated. In this case, the retrieved information is the method of the
    selected context."
    | selector classOfMethod category method priorMethod parseNode |
    contextStackIndex = 0 ifTrue: [^self].
    (self selectedContext isKindOf: MethodContext)
        ifFalse:
            [(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
                ifTrue: [self resetContext: self selectedContext home]
                ifFalse: [^self]].
    classOfMethod _ self selectedClass.
    category _ self selectedMessageCategoryName.
    Cursor execute showWhile:
        [method _ classOfMethod
        compile: aText
        notifying: aController
        trailer: #(0 0 0 0)
        ifFail: [^ false]
        elseSetSelectorAndNode:
            [:sel :methodNode | selector _ sel.
            selector == self selectedMessageName
                ifFalse: [self notify: 'can''t change selector'. ^ false].
            priorMethod _ (classOfMethod includesSelector: selector)
                ifTrue: [classOfMethod compiledMethodAt: selector]
                ifFalse: [nil].
            sourceMap _ methodNode sourceMap.
            tempNames _ methodNode tempNames.
            parseNode _ methodNode].
        method cacheTempNames: tempNames].
    category isNil ifFalse: "Skip this for DoIts"
        [method putSource: aText
                fromParseNode: parseNode
                class: classOfMethod
                category: category
                inFile: 2 priorMethod: priorMethod.
        classOfMethod organization classify: selector under: category].
    contents _ aText copy.
    self selectedContext restartWith: method.
    contextVariablesInspector object: nil.
    self resetContext: self selectedContext.
    ^true! !

!Debugger methodsFor: 'accessing'!
contextVariablesInspector
    "Answer the instance of Inspector that is providing a view of the
    variables of the selected context."

    ^contextVariablesInspector! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 12:16'!
doNothing: newText
    "Notifier window can't accept text"! !

!Debugger methodsFor: 'accessing'!
interruptedContext
    "Answer the suspended context of the interrupted process."

    ^contextStackTop! !

!Debugger methodsFor: 'accessing'!
interruptedProcess
    "Answer the interrupted process."

    ^interruptedProcess! !

!Debugger methodsFor: 'accessing' stamp: 'tk 4/16/1998 15:47'!
isNotifier
    "Return true if this debugger has not been expanded into a full sized window"

    ^ receiverInspector == nil! !

!Debugger methodsFor: 'accessing'!
proceedValue
    "Answer the value to return to the selected context when the interrupted
    process proceeds."

    ^proceedValue! !

!Debugger methodsFor: 'accessing'!
proceedValue: anObject
    "Set the value to be returned to the selected context when the interrupted
    process proceeds."

    proceedValue _ anObject! !

!Debugger methodsFor: 'accessing'!
receiver
    "Answer the receiver of the selected context, if any. Answer nil
    otherwise."

    contextStackIndex = 0
        ifTrue: [^nil]
        ifFalse: [^self selectedContext receiver]! !

!Debugger methodsFor: 'accessing'!
receiverInspector
    "Answer the instance of Inspector that is providing a view of the
    variables of the selected context's receiver."

    ^receiverInspector! !


!Debugger methodsFor: 'notifier menu' stamp: 'di 5/5/1998 00:00'!
debug
    "Open a full DebuggerView."
    | topView |
    topView _ self topView.
    topView model: nil.  "so close won't release me."
    World ifNotNil:
        [self openFullMorphicLabel: topView label.
        ^ topView delete].
    topView controller controlTerminate.
    topView deEmphasizeView; erase.
    self openFullNoSuspendLabel: topView label.
    topView controller closeAndUnscheduleNoErase.
    Processor terminateActive.
! !


!Debugger methodsFor: 'context stack (message list)'!
contextStackIndex
    "Answer the index of the selected context."

    ^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)'!
contextStackList
    "Answer the array of contexts."

    ^contextStackList! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'tk 4/17/1998 18:05'!
expandStack
    "A Notifier is being turned into a full debugger.  Show a substantial amount of stack in the context pane."

    self newStack: (contextStackTop stackOfSize: 20).
    contextStackIndex _ 0.
    receiverInspector _ Inspector inspect: nil.
    contextVariablesInspector _ ContextVariablesInspector inspect: nil.
    proceedValue _ nil! !

!Debugger methodsFor: 'context stack (message list)'!
fullyExpandStack
    "Expand the stack to include all of it, rather than the first four or five
    contexts."

    self okToChange ifFalse: [^ self].
    self newStack: contextStackTop stack.
    self changed: #contextStackList! !

!Debugger methodsFor: 'context stack (message list)'!
messageListIndex
    "Answer the index of the currently selected context."

    ^contextStackIndex! !

!Debugger methodsFor: 'context stack (message list)'!
selectedMessage
    "Answer the source code of the currently selected context."

    contents == nil ifTrue: [contents _ self selectedContext sourceCode].
    ^contents! !

!Debugger methodsFor: 'context stack (message list)'!
selectedMessageName
    "Answer the message selector of the currently selected context."

    ^self selectedContext selector! !

!Debugger methodsFor: 'context stack (message list)' stamp: 'tk 4/6/98 23:00'!
spawn: aString
    "Create and schedule a message browser on the message, aString. Any
    edits already made are retained."

    self messageListIndex > 0
        ifTrue:
            [^Browser
                openMessageBrowserForClass: self selectedClass
                selector: self selectedMessageName
                editString: aString]! !

!Debugger methodsFor: 'context stack (message list)'!
toggleContextStackIndex: anInteger
    "If anInteger is the same as the index of the selected context, deselect it.
    Otherwise, the context whose index is anInteger becomes the selected
    context."

    self contextStackIndex:
        (contextStackIndex = anInteger
            ifTrue: [0]
            ifFalse: [anInteger])
        oldContextWas:
        (contextStackIndex = 0
            ifTrue: [nil]
            ifFalse: [contextStack at: contextStackIndex])! !


!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'!
browseMessages
    "Present a menu of all messages sent by the currently selected message.
    Open a message set browser of all implementors of the message chosen.
    Do nothing if no message is chosen."

    contextStackIndex = 0 ifTrue: [^ self].
    super browseMessages.! !

!Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'!
browseSendersOfMessages
    "Present a menu of the currently selected message, as well as all
    messages sent by it.  Open a message set browser of all implementors
    of the message chosen."

    contextStackIndex = 0 ifTrue: [^ self].
    super browseSendersOfMessages! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 8/6/97 14:26'!
browseVersions
    "Create and schedule a message set browser on all versions of the
    currently selected message selector."
    | class selector |
    class _ self selectedClassOrMetaClass.
    selector _ self selectedMessageName.
    ChangeList
        browseVersionsOf: (class compiledMethodAt: selector)
        class: self selectedClass
        meta: self selectedClass isMeta
        category: self selectedMessageCategoryName
        selector: selector! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/6/98 23:00'!
buildMessageBrowser
    "Create and schedule a message browser on the current method."

    contextStackIndex = 0 ifTrue: [^ self].
    ^ Browser
        openMessageBrowserForClass: self selectedClassOrMetaClass
        selector: self selectedMessageName
        editString: nil! !

!Debugger methodsFor: 'context stack menu'!
close: aScheduledController
    "The argument is a controller on a view of the receiver.
    That view is closed."

    aScheduledController close
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/18/1998 09:24'!
contextStackKey: aChar from: view
    "Respond to a keystroke in the context list"

     | selector |
    selector _ ContextStackKeystrokes at: aChar ifAbsent: [nil].
    selector ifNil: [self messageListKey: aChar from: view]
        ifNotNil: [self perform: selector]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/21/1998 07:51'!
contextStackMenu: aMenu shifted: shifted
    ^ shifted ifFalse: [aMenu labels:
'fullStack (f)
restart (r)
proceed (p)
step (t)
send (e)
where (w)
senders of...
implementors of...
method inheritance
versions
inst var refs...
inst var defs...
class var refs...
class variables
class refs
browse full
more...'
    lines: #(6 10 12 15)
    selections: #(fullStack restart proceed step send where
browseSendersOfMessages browseMessages methodHierarchy browseVersions
browseInstVarRefs browseInstVarDefs
browseClassVarRefs browseClassVariables browseClassRefs
browseMethodFull
shiftedYellowButtonActivity)]

    ifTrue: [aMenu labels:
'browse class hierarchy
browse class
browse method
implementors of sent messages
change sets with this method
inspect instances
inspect subinstances
remove from current change set
more...'
    lines: #(5 7 9)
    selections: #(classHierarchy browseClass
        buildMessageBrowser browseAllMessages findMethodInChangeSets
        inspectInstances inspectSubInstances
        removeFromCurrentChanges
        unshiftedYellowButtonActivity)]

! !

!Debugger methodsFor: 'context stack menu' stamp: 'sw 8/6/97 13:45'!
currentCompiledMethod
    ^ self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 12:19'!
debugProceedMenu: aMenu
    ^ aMenu labels:
'proceed
debug'
    lines: #()
    selections: #(proceed debug )
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
down
    "move down the context stack to the previous (enclosing) context"

    self toggleContextStackIndex: contextStackIndex+1! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/17/1998 18:06'!
fullStack
    "Change from displaying the minimal stack to a full one."

    self contextStackList size > 20 "Already expanded"
        ifTrue:
            [self changed: #flash]
        ifFalse:
            [self contextStackIndex = 0 ifFalse: [
                self toggleContextStackIndex: self contextStackIndex].
            self fullyExpandStack]! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'!
proceed
    "Proceed execution of the receiver's model, starting after the expression at
    which an interruption occurred."

    Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [
        self proceed: self topView].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'!
proceed: aTopView
    "Proceed from the interrupted state of the currently selected context. The
    argument is the topView of the receiver. That view is closed."

    self okToChange ifFalse: [^ self].
    self checkContextSelection.
    contextStackIndex > 1 | externalInterrupt not
        ifTrue: [self selectedContext push: proceedValue].
    self resumeProcess: aTopView! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'!
restart
    "Proceed execution of the receiver's model, starting at the beginning of
    the currently selected method."

    self restart: self topView.
! !

!Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:08'!
restart: aTopView
    "Proceed from the initial state of the currently selected context. The
    argument is a controller on a view of the receiver. That view is closed."

    self okToChange ifFalse: [^ self].
    self checkContextSelection.
    (self selectedContext isKindOf: MethodContext)
        ifFalse:
            [(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
                ifTrue: [self resetContext: self selectedContext home]
                ifFalse: [^self]].
    self selectedContext restart.
    self resumeProcess: aTopView! !

!Debugger methodsFor: 'context stack menu'!
selectPC
    "Toggle the flag telling whether to automatically select the expression
    currently being executed by the selected context."

    selectingPC _ selectingPC not! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/16/1998 11:36'!
send
    "Send the selected message in the accessed method, and take control in
    the method invoked to allow further step or
send."

    | currentContext |
    "Sensor leftShiftDown ifTrue: [self halt]."
    self okToChange ifFalse: [^ self].
    self checkContextSelection.
    externalInterrupt ifFalse: [contextStackTop push: proceedValue].
    externalInterrupt _ true. "simulation leaves same state as interrupting"
    currentContext _ self selectedContext.
    currentContext stepToSendOrReturn.
    self contextStackIndex > 1 | currentContext willReturn
        ifTrue:
            [self changed: #notChanged]
        ifFalse:
            [currentContext _ currentContext step.
            currentContext stepToSendOrReturn.
            self resetContext: currentContext]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/18/1998 15:08'!
shiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self contextStackMenu: (CustomMenu new) shifted: true.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'sn 9/6/97 16:27'!
step
    "Send the selected message in the accessed method, and regain control
    after the invoked method returns."

    | currentContext oldMethod |
    self okToChange ifFalse: [^ self].
    self checkContextSelection.
    externalInterrupt ifFalse: [contextStackTop push: proceedValue].
    externalInterrupt _ true. "simulation leaves same state as interrupting"
    currentContext _ self selectedContext.
    self contextStackIndex > 1
        ifTrue:
            [currentContext completeCallee: contextStackTop.
            self resetContext: currentContext]
        ifFalse:
            [currentContext stepToSendOrReturn.
            currentContext willReturn
                ifTrue:
                    [oldMethod _ currentContext method.
                    currentContext _ currentContext step.
                    currentContext stepToSendOrReturn.
                    self resetContext: currentContext.
                    oldMethod == currentContext method "didnt used to update pc here"
                        ifTrue: [self changed: #pc]]
                ifFalse:
                    [currentContext completeCallee: currentContext step.
                    self changed: #pc.
                    self updateInspectors]]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/21/1998 09:05'!
unshiftedYellowButtonActivity
    "Invoke the model's other menu.  Just do what the controller would have done."

    | menu |
    menu _ self contextStackMenu: (CustomMenu new) shifted: false.
    menu == nil
        ifTrue: [Sensor waitNoButton]
        ifFalse: [menu invokeOn: self].
! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'!
up
    "move up the context stack to the next (enclosed) context"

    contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! !

!Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:54'!
where
    "Select the expression whose evaluation was interrupted."

    self selectPC! !


!Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'!
contentsSelection

    ^ self pcRange! !

!Debugger methodsFor: 'code pane'!
doItContext
    "Answer the context in which a text selection can be evaluated."

    contextStackIndex = 0
        ifTrue: [^super doItContext]
        ifFalse: [^self selectedContext]! !

!Debugger methodsFor: 'code pane'!
doItReceiver
    "Answer the object that should be informed of the result of evaluating a
    text selection."

    ^self receiver! !

!Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'!
pc

    ^ self pcRange! !

!Debugger methodsFor: 'code pane'!
pcRange
    "Answer the indices in the source code for the method corresponding to
    the selected context's program counter value."

    | i methodNode pc end |
    (selectingPC and: [contextStackIndex ~= 0])
        ifFalse: [^1 to: 0].
    sourceMap == nil ifTrue:
        [methodNode _ self selectedClass compilerClass new
            parse: self selectedMessage
            in: self selectedClass
            notifying: nil.
        sourceMap _ methodNode sourceMap.
        tempNames _ methodNode tempNames.
        self selectedContext method cacheTempNames: tempNames].
    sourceMap size = 0 ifTrue: [^1 to: 0].
    pc_ self selectedContext pc -
        ((externalInterrupt and: [contextStackIndex=1])
            ifTrue: [1]
            ifFalse: [2]).
    i _ sourceMap indexForInserting: (Association key: pc value: nil).
    i < 1 ifTrue: [^1 to: 0].
    i > sourceMap size
        ifTrue:
            [end _ sourceMap inject: 0 into:
                [:prev :this | prev max: this value last].
            ^ end+1 to: end].
    ^(sourceMap at: i) value! !


!Debugger methodsFor: 'code pane menu' stamp: 'tk 4/17/1998 17:25'!
perform: selector orSendTo: otherTarget
    "Selector was just chosen from a menu by a user.  If can respond, then perform it on myself.  If not, send it to otherTarget, presumably the editPane from which the menu was invoked."

    | result |
    (#(debug proceed) includes: selector)        "When I am a notifier window"
        ifTrue: [^ self perform: selector]
        ifFalse: [result _ super perform: selector orSendTo: otherTarget.
                selector == #doIt ifTrue: [
                    result ~~ #failedDoit ifTrue: [self proceedValue: result]].
                ^ result]! !


!Debugger methodsFor: 'message category list'!
selectedMessageCategoryName
    "Answer the name of the message category of the message of the
    currently selected context."

    ^self selectedClass organization categoryOfElement: self selectedMessageName! !


!Debugger methodsFor: 'class list'!
selectedClass
    "Answer the class in which the currently selected context's method was
    found."

    ^self selectedContext mclass! !

!Debugger methodsFor: 'class list'!
selectedClassOrMetaClass
    "Answer the class in which the currently selected context's method was
    found."

    ^self selectedContext mclass! !


!Debugger methodsFor: 'dependents access'!
updateInspectors
    "Update the inspectors on the receiver's variables."

    receiverInspector update.
    contextVariablesInspector update! !


!Debugger methodsFor: 'private'!
checkContextSelection

    contextStackIndex = 0 ifTrue: [contextStackIndex _ 1]! !

!Debugger methodsFor: 'private' stamp: 'di 5/13/1998 14:07'!
contextStackIndex: anInteger oldContextWas: oldContext

    | newMethod |
    contextStackIndex _ anInteger.
    anInteger = 0
        ifTrue:
            [tempNames _ sourceMap _ contents _ nil.
            self changed: #contextStackIndex.
            self changed: #contents.
            contextVariablesInspector object: nil.
            receiverInspector object: self receiver.
            ^self].
    (newMethod _ oldContext == nil or:
        [oldContext method ~~ self selectedContext method])
        ifTrue:
            [tempNames _ sourceMap _ nil.
            contents _ self selectedContext sourceCode.
            self changed: #contents.
            self pcRange "will compute tempNamesunless noFrills"].
    self changed: #contextStackIndex.
    tempNames == nil
        ifTrue: [tempNames _
                    self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil].
    contextVariablesInspector object: self selectedContext.
    receiverInspector object: self receiver.
    newMethod ifFalse: [self changed: #contentsSelection]! !

!Debugger methodsFor: 'private'!
externalInterrupt: aBoolean

    externalInterrupt _ aBoolean ! !

!Debugger methodsFor: 'private' stamp: 'jm 5/1/1998 16:20'!
lowSpaceChoices
    "Return a notifier message string to be presented when space is running low."

    ^ 'Warning!! Squeak is almost out of memory!!

Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution.

Here are some suggestions:

ƒ If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem.

ƒ If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available...
   > Close any windows that are not needed.
   > Get rid of some large objects (e.g., images).
   > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window.

ƒ If you want to investigate further, choose "debug" in this window.  Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!).

'
! !

!Debugger methodsFor: 'private'!
newStack: stack
    | oldStack diff |
    oldStack _ contextStack.
    contextStack _ stack.
    (oldStack == nil or: [oldStack last ~~ stack last])
        ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString].
                ^ self].
    "May be able to re-use some of previous list"
    diff _ stack size - oldStack size.
    contextStackList _ diff <= 0
        ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size]
        ifFalse: [diff > 1
                ifTrue: [contextStack collect: [:ctx | ctx printString]]
                ifFalse: [(Array with: stack first printString) , contextStackList]]! !

!Debugger methodsFor: 'private'!
process: aProcess controller: aController context: aContext

    super initialize.
    contents _ nil.
    interruptedProcess _ aProcess.
    interruptedController _ aController.
    contextStackTop _ aContext.
    self newStack: (contextStackTop stackOfSize: 1).
    contextStackIndex _ 1.
    externalInterrupt _ false.
    selectingPC _ true! !

!Debugger methodsFor: 'private' stamp: 'tk 4/15/1998 19:04'!
resetContext: aContext
    "Used when a new context becomes top-of-stack, for instance when the
    method of the selected context is re-compiled, or the simulator steps or
    returns to a new method. There is room for much optimization here, first
    to save recomputing the whole stack list (and text), and secondly to avoid
    recomposing all that text (by editing the paragraph instead of recreating it)."

    | oldContext |
    oldContext _ self selectedContext.
    contextStackTop _ aContext.
    self newStack: contextStackTop stack.
    self changed: #contextStackList.
    self contextStackIndex: 1 oldContextWas: oldContext.
    self changed: #content.! !

!Debugger methodsFor: 'private' stamp: 'di 5/5/1998 00:20'!
resumeProcess: aTopView
    World ifNil: [aTopView erase].
    Smalltalk installLowSpaceWatcher.  "restart low space handler"
    interruptedProcess suspendedContext method
            == (Process compiledMethodAt: #terminate) ifFalse:
        [contextStackIndex > 1
            ifTrue: [interruptedProcess popTo: self selectedContext]
            ifFalse: [interruptedProcess install: self selectedContext].
        World ifNil: [ScheduledControllers
                        activeControllerNoTerminate: interruptedController
                        andProcess: interruptedProcess]
            ifNotNil: [interruptedProcess resume]].
    "if old process was terminated, just terminate current one"
    interruptedProcess _ nil.
    World ifNil: [aTopView controller closeAndUnscheduleNoErase]
        ifNotNil: [aTopView delete].
    Processor terminateActive
! !

!Debugger methodsFor: 'private'!
selectedContext

    contextStackIndex = 0
        ifTrue: [^contextStackTop]
        ifFalse: [^contextStack at: contextStackIndex]! !

"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Debugger class
    instanceVariableNames: ''!

!Debugger class methodsFor: 'class initialization' stamp: 'di 5/22/1998 14:52'!
initialize
    ErrorRecursion _ false.
    ContextStackKeystrokes _ Dictionary new
        at: $e put: #send;
        at: $t put: #step;
        at: $p put: #proceed;
        at: $r put: #restart;
        at: $f put: #fullStack;
        at: $w put: #where;
        yourself.

    "Debugger initialize"! !


!Debugger class methodsFor: 'instance creation' stamp: 'jm 5/1/1998 16:31'!
context: aContext
    "Answer an instance of me for debugging the active process starting with the given context."

    ^ self new
        process: Processor activeProcess
        controller:
            (ScheduledControllers inActiveControllerProcess
                ifTrue: [ScheduledControllers activeController]
                ifFalse: [nil])
        context: aContext
! !


!Debugger class methodsFor: 'opening' stamp: 'di 5/4/1998 15:43'!
openContext: aContext label: aString contents: contentsString
    "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."

    ErrorRecursion ifTrue:
        [ErrorRecursion _ false.
        self primitiveError: aString].
    ErrorRecursion _ true.
    (Debugger context: aContext)
        openNotifierContents: contentsString
        label: aString.
    ErrorRecursion _ false.
    Processor activeProcess suspend.
! !

!Debugger class methodsFor: 'opening' stamp: 'jm 5/1/1998 18:05'!
openInterrupt: aString onProcess: interruptedProcess
    "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."

    | debugger |
    debugger _ self new.
    debugger
        process: interruptedProcess
        controller: (ScheduledControllers activeControllerProcess == interruptedProcess
                        ifTrue: [ScheduledControllers activeController])
        context: interruptedProcess suspendedContext.
    debugger externalInterrupt: true.
    ^ debugger
        openNotifierContents: debugger interruptedContext shortStack
        label: aString
! !
InstructionStream subclass: #Decompiler
    instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit lastJumpPc lastReturnPc limit hasValue blockStackBase '
    classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag '
    poolDictionaries: ''
    category: 'System-Compiler'!
!Decompiler commentStamp: 'di 5/22/1998 16:33' prior: 0!
Decompiler comment:
'I decompile a method in three phases:
    Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
    Parser: prefix symbolic codes -> node tree (same as the compiler)
    Printer: node tree -> text (done by the nodes)'!


!Decompiler methodsFor: 'initialize-release'!
initSymbols: aClass
    | nTemps namedTemps |
    constructor method: method class: aClass literals: method literals.
    constTable _ constructor codeConstants.
    instVars _ Array new: aClass instSize.
    nTemps _ method numTemps.
    namedTemps _ tempVars == nil ifTrue: [Array new] ifFalse: [tempVars].
    tempVars _ (1 to: nTemps) collect:
                [:i | i <= namedTemps size
                    ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)]
                    ifFalse: [constructor codeTemp: i - 1]]! !

!Decompiler methodsFor: 'initialize-release'!
withTempNames: tempNameArray
    tempVars _ tempNameArray! !


!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!
blockForCaseTo: end
    "Decompile a range of code as in statementsForCaseTo:, but return a block node."
    | exprs block oldBase |
    oldBase _ blockStackBase.
    blockStackBase _ stack size.
    exprs _ self statementsForCaseTo: end.
    block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
    blockStackBase _ oldBase.
    lastReturnPc _ -1.  "So as not to mislead outer calls"
    ^block! !

!Decompiler methodsFor: 'control'!
blockTo: end
    "Decompile a range of code as in statementsTo:, but return a block node."
    | exprs block oldBase |
    oldBase _ blockStackBase.
    blockStackBase _ stack size.
    exprs _ self statementsTo: end.
    block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
    blockStackBase _ oldBase.
    lastReturnPc _ -1.  "So as not to mislead outer calls"
    ^block! !

!Decompiler methodsFor: 'control'!
checkForBlock: receiver
    "We just saw a blockCopy: message. Check for a following block."

    | savePc jump args argPos block |
    receiver == constructor codeThisContext ifFalse: [^false].
    savePc _ pc.
    (jump _ self interpretJump) notNil
        ifFalse:
            [pc _ savePc.  ^nil].
    "Definitely a block"
    jump _ jump + pc.
    argPos _ statements size.
    [self willStorePop]
        whileTrue:
            [stack addLast: ArgumentFlag.  "Flag for doStore:"
            self interpretNextInstructionFor: self].
    args _ Array new: statements size - argPos.
    1 to: args size do:  "Retrieve args"
        [:i | args at: i put: statements removeLast.
        (args at: i) scope: -1  "flag args as block temps"].
    block _ self blockTo: jump.
    stack addLast: (constructor codeArguments: args block: block).
    ^true! !

!Decompiler methodsFor: 'control' stamp: 'tao 8/20/97 22:51'!
statementsForCaseTo: end
    "Decompile the method from pc up to end and return an array of
    expressions. If at run time this block will leave a value on the stack,
    set hasValue to true. If the block ends with a jump or return, set exit
    to the destination of the jump, or the end of the method; otherwise, set
    exit = end. Leave pc = end.
    Note that stack initially contains a CaseFlag which will be removed by
    a subsequent Pop instruction, so adjust the StackPos accordingly."

    | blockPos stackPos t |
    blockPos _ statements size.
    stackPos _ stack size - 1. "Adjust for CaseFlag"
    [pc < end]
        whileTrue:
            [lastPc _ pc.  limit _ end.  "for performs"
            self interpretNextInstructionFor: self].
    "If there is an additional item on the stack, it will be the value
    of this block."
    (hasValue _ stack size > stackPos)
        ifTrue:
            [statements addLast: stack removeLast].
    lastJumpPc = lastPc ifFalse: [exit _ pc].
    ^self popTo: blockPos! !

!Decompiler methodsFor: 'control'!
statementsTo: end
    "Decompile the method from pc up to end and return an array of
    expressions. If at run time this block will leave a value on the stack,
    set hasValue to true. If the block ends with a jump or return, set exit
    to the destination of the jump, or the end of the method; otherwise, set
    exit = end. Leave pc = end."

    | blockPos stackPos t |
    blockPos _ statements size.
    stackPos _ stack size.
    [pc < end]
        whileTrue:
            [lastPc _ pc.  limit _ end.  "for performs"
            self interpretNextInstructionFor: self].
    "If there is an additional item on the stack, it will be the value
    of this block."
    (hasValue _ stack size > stackPos)
        ifTrue:
            [statements addLast: stack removeLast].
    lastJumpPc = lastPc ifFalse: [exit _ pc].
    ^self popTo: blockPos! !


!Decompiler methodsFor: 'instruction decoding'!
blockReturnTop
    "No action needed"! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'tao 8/20/97 22:49'!
case: dist
    "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"

    | nextCase end thenJump stmtStream elements b node cases otherBlock |
    nextCase _ pc + dist.
    end _ limit.
    "Now add CascadeFlag & keyValueBlock to statements"
    statements addLast: stack removeLast.
    stack addLast: CaseFlag. "set for next pop"
    statements addLast: (self blockForCaseTo: nextCase).
    stack last == CaseFlag
        ifTrue: "Last case"
            ["ensure jump is within block (in case thenExpr returns wierdly I guess)"
            stack removeLast. "get rid of CaseFlag".
            thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase].
            stmtStream _ ReadStream on: (self popTo: stack removeLast).
            elements _ OrderedCollection new.
            b _ OrderedCollection new.
            [stmtStream atEnd] whileFalse:
                [(node _ stmtStream next) == CascadeFlag
                    ifTrue:
                        [elements addLast: (constructor
                            codeMessage: (constructor codeBlock: b returns: false)
                            selector: (constructor codeSelector: #-> code: #macro)
                            arguments: (Array with: stmtStream next)).
                         b _ OrderedCollection new]
                    ifFalse: [b addLast: node]].
            b size > 0 ifTrue: [self error: 'Bad cases'].
            cases _ constructor codeBrace: elements.
            otherBlock _ self blockTo: thenJump.
            stack addLast:
                (constructor
                    codeMessage: stack removeLast
                    selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
                    arguments: (Array with: cases with: otherBlock))]! !

!Decompiler methodsFor: 'instruction decoding'!
doDup

    stack last == CascadeFlag
        ifFalse:
            ["Save position and mark cascade"
            stack addLast: statements size.
            stack addLast: CascadeFlag].
    stack addLast: CascadeFlag! !

!Decompiler methodsFor: 'instruction decoding' stamp: 'tao 8/20/97 22:54'!
doPop

    stack last == CaseFlag
        ifTrue: [stack removeLast]
        ifFalse: [statements addLast: stack removeLast].! !

!Decompiler methodsFor: 'instruction decoding'!
doStore: stackOrBlock
    "Only called internally, not from InstructionStream. StackOrBlock is stack
    for store, statements for storePop."

    | var expr |
    var _ stack removeLast.
    expr _ stack removeLast.
    stackOrBlock addLast: (expr == ArgumentFlag
        ifTrue: [var]
        ifFalse: [constructor codeAssignTo: var value: expr])! !

!Decompiler methodsFor: 'instruction decoding'!
jump: dist

    exit _ pc + dist.
    lastJumpPc _ lastPc! !

!Decompiler methodsFor: 'instruction decoding'!
jump: dist if: condition

    | savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump
        elseJump condHasValue b |
    stack last == CascadeFlag ifTrue: [^self case: dist].
    elsePc _ lastPc.
    elseStart _ pc + dist.
    end _ limit.
    "Check for bfp-jmp to invert condition.
    Don't be fooled by a loop with a null body."
    sign _ condition.
    savePc _ pc.
    ((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])
        ifTrue: [sign _ sign not.  elseStart _ pc + elseDist]
        ifFalse: [pc _ savePc].
    ifExpr _ stack removeLast.
    thenBlock _ self blockTo: elseStart.
    condHasValue _ hasValue.
    "ensure jump is within block (in case thenExpr returns)"
    thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].
    "if jump goes back, then it's a loop"
    thenJump < elseStart
        ifTrue:
            ["thenJump will jump to the beginning of the while expr.  In the case of
            while's with a block in the condition, the while expr
            should include more than just the last expression: find all the
            statements needed by re-decompiling."
            pc _ thenJump.
            b _ self statementsTo: elsePc.
            "discard unwanted statements from block"
            b size - 1 timesRepeat: [statements removeLast].
            statements addLast: (constructor
                    codeMessage: (constructor codeBlock: b returns: false)
                    selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)
                    arguments: (Array with: thenBlock)).
            pc _ elseStart.
            self convertToDoLoop]
        ifFalse:
            [elseBlock _ self blockTo: thenJump.
            elseJump _ exit.
            "if elseJump is backwards, it is not part of the elseExpr"
            elseJump < elsePc
                ifTrue: [pc _ lastPc].
            cond _ constructor
                        codeMessage: ifExpr
                        selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
                        arguments:
                            (sign
                                ifTrue: [Array with: elseBlock with: thenBlock]
                                ifFalse: [Array with: thenBlock with: elseBlock]).
            condHasValue
                ifTrue: [stack addLast: cond]
                ifFalse: [statements addLast: cond]]! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnConstant: value

    self pushConstant: value; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnReceiver

    self pushReceiver; methodReturnTop! !

!Decompiler methodsFor: 'instruction decoding'!
methodReturnTop
    | last |
    last _ stack removeLast.
    stack size > blockStackBase  "get effect of elided pop before return"
        ifTrue: [statements addLast: stack removeLast].
    exit _ method size + 1.
    lastJumpPc _ lastReturnPc _ lastPc.
    statements addLast: last! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoLiteralVariable: value

    self pushLiteralVariable: value; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoReceiverVariable: offset

    self pushReceiverVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
popIntoTemporaryVariable: offset

    self pushTemporaryVariable: offset; doStore: statements! !

!Decompiler methodsFor: 'instruction decoding'!
pushActiveContext

    stack addLast: constructor codeThisContext! !

!Decompiler methodsFor: 'instruction decoding'!
pushConstant: value

    | node |
    node _ value == true ifTrue: [constTable at: 2]
        ifFalse: [value == false ifTrue: [constTable at: 3]
        ifFalse: [value == nil ifTrue: [constTable at: 4]
        ifFalse: [constructor codeAnyLiteral: value]]].
    stack addLast: node! !

!Decompiler methodsFor: 'instruction decoding'!
pushLiteralVariable: assoc

    stack addLast: (constructor codeAnyLitInd: assoc)! !

!Decompiler methodsFor: 'instruction decoding'!
pushReceiver

    stack addLast: (constTable at: 1)! !

!Decompiler methodsFor: 'instruction decoding'!
pushReceiverVariable: offset

    | var |
    (var _ instVars at: offset + 1) == nil
        ifTrue:
            ["Not set up yet"